protobuf-0.2.1.3/0000755000000000000000000000000007346545000011704 5ustar0000000000000000protobuf-0.2.1.3/CHANGELOG0000755000000000000000000000207007346545000013120 0ustar00000000000000000.2.1.2: - Fix #36: Compile on GHC >= 8.0 0.2.1.1: - Fix #26: Import orphan Foldable Last instance from base-orphans - Fix #27: Fix failure when decoding empty [packed] fields 0.2.1.0: - Fix #17: Repeated n (Enumeration a) difficulty 0.2.0.4: - Fix #13: Getting the error "Always is not a Monoid 0.2.0.3: - Fix #11: Missing optional enum in incoming message causes decodeMessage to fail 0.2.0.2: - Export {get,put}Varint* from Data.ProtocolBuffers.Internal 0.2.0.1: - Dropped ghc-prim dependency, what we need is now exported from base - Added this CHANGELOG 0.2.0: - Transitioned to the compiler supported GHC.TypeLits, requiring GHC 7.8+ - Stopped building the protoc-gen-hs plugin, which is not functional - Migrated tests from test-framework to tasty 0.1.3: - Decoding performance has been improved for Repeated fields - A Foldable instance for Last has been added to Data.ProtocolBuffers.Orphans 0.1.2: - Enumerations can now be encoded 0.1.1: - Support empty messages, messages with no fields - Packed field support has been improved protobuf-0.2.1.3/LICENSE0000644000000000000000000000274007346545000012714 0ustar0000000000000000Copyright (c) 2012, Alpha Heavy Industries, Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither the names of the copyright owners nor the names of the contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. protobuf-0.2.1.3/LICENSE.google-protobuf0000755000000000000000000000330407346545000016025 0ustar0000000000000000Copyright 2008, Google Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Google Inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Code generated by the Protocol Buffer compiler is owned by the owner of the input file used when generating it. This code is not standalone and requires a support library to be linked with it. This support library is itself covered by the above license. protobuf-0.2.1.3/LICENSE.haskell-protocol-buffers0000755000000000000000000000274107346545000017633 0ustar0000000000000000Copyright (c) 2008, Christopher Edward Kuklewicz All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holder nor the names of the contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. protobuf-0.2.1.3/Setup.hs0000644000000000000000000000005607346545000013341 0ustar0000000000000000import Distribution.Simple main = defaultMain protobuf-0.2.1.3/protobuf.cabal0000644000000000000000000000575007346545000014537 0ustar0000000000000000name: protobuf version: 0.2.1.3 synopsis: Google Protocol Buffers via GHC.Generics description: Google Protocol Buffers via GHC.Generics. . Protocol Buffers are a way of encoding structured data in an efficient yet extensible format. Google uses Protocol Buffers for almost all of its internal RPC protocols and file formats. . This library supports a useful subset of Google Protocol Buffers message specifications in a Haskell. No preprocessor or additional build steps are required for message encoding and decoding. . Record specifications are built by defining records with specially defined fields that capture most of the Protocol Buffers specification language. . license: BSD3 license-file: LICENSE extra-source-files: LICENSE.google-protobuf, LICENSE.haskell-protocol-buffers, CHANGELOG author: Steve Severance, Nathan Howell maintainer: sseverance@alphaheavy.com, nhowell@alphaheavy.com homepage: https://github.com/alphaHeavy/protobuf bug-reports: https://github.com/alphaHeavy/protobuf/issues category: Data build-type: Simple cabal-version: >= 1.10 extra-source-files: tests/Main.hs library default-language: Haskell2010 hs-source-dirs: src exposed-modules: Data.ProtocolBuffers Data.ProtocolBuffers.Internal Data.ProtocolBuffers.Orphans other-modules: Data.ProtocolBuffers.Decode Data.ProtocolBuffers.Encode Data.ProtocolBuffers.Message -- Data.ProtocolBuffers.Ppr Data.ProtocolBuffers.Types Data.ProtocolBuffers.Wire build-depends: base >= 4.7 && < 5, base-orphans >= 0.5, bytestring >= 0.9, cereal >= 0.3, data-binary-ieee754 >= 0.4, deepseq >= 1.1, mtl == 2.*, -- pretty, text >= 0.10, unordered-containers >= 0.2 ghc-options: -Wall if impl(ghc < 8.0) build-depends: semigroups == 0.18.* -- executable protoc-gen-hs -- default-language: -- Haskell2010 -- hs-source-dirs: -- plugin -- main-is: -- Main.hs -- build-depends: -- base >= 4.7 && < 5, -- bytestring, -- cereal, -- ghc-prim, -- haskell-src-exts, -- mtl, -- protobuf, -- text, -- unordered-containers -- ghc-options: -- -Wall test-suite protobuf-test default-language: Haskell2010 hs-source-dirs: tests type: exitcode-stdio-1.0 main-is: Main.hs build-depends: base >= 4.7 && < 5, bytestring, cereal, containers, hex, mtl, protobuf, tagged, text, unordered-containers, tasty, tasty-hunit, tasty-quickcheck, HUnit >= 1.2, QuickCheck >= 2.4 source-repository head type: git location: https://github.com/alphaHeavy/protobuf.git protobuf-0.2.1.3/src/Data/0000755000000000000000000000000007346545000013344 5ustar0000000000000000protobuf-0.2.1.3/src/Data/ProtocolBuffers.hs0000644000000000000000000001251707346545000017024 0ustar0000000000000000-- | -- -- An implementation of Protocol Buffers in pure Haskell. -- -- Extensive documentation is available at -- and Google's reference implementation can be found at . -- -- It is intended to be used via "GHC.Generics" and does not require @ .proto @ files to function. -- Tools are being developed that will convert a Haskell Protobuf definition into a @ .proto @ and vice versa. -- -- Given a message definition: -- -- @ --{-\# LANGUAGE DeriveGeneric \#-} --{-\# LANGUAGE DataKinds \#-} -- --import "Data.Int" --import "Data.ProtocolBuffers" --import "Data.Text" --import "GHC.Generics" ('GHC.Generics.Generic') --import "GHC.TypeLits" --import "Data.Monoid" --import "Data.Serialize" --import "Data.Hex" -- cabal install hex (for testing) -- -- data Foo = Foo -- { field1 :: 'Required' 1 ('Value' 'Data.Int.Int64') -- ^ The last field with tag = 1 -- , field2 :: 'Optional' 2 ('Value' 'Data.Text.Text') -- ^ The last field with tag = 2 -- , field3 :: 'Repeated' 3 ('Value' 'Prelude.Bool') -- ^ All fields with tag = 3, ordering is preserved -- } deriving ('GHC.Generics.Generic', 'Prelude.Show') -- --instance 'Encode' Foo --instance 'Decode' Foo -- @ -- -- It can then be used for encoding and decoding. The 'Encode' and 'Decode' instances are derived automatically -- using DeriveGeneric and DefaultSignatures as outlined here: . -- -- To construct a message, use 'putField' to set each field value. 'Optional', 'Repeated' and 'Packed' -- fields can be set to their empty value by using 'Data.Monoid.mempty'. An example using record syntax for clarity: -- -- >>> let msg = Foo{field1 = putField 42, field2 = mempty, field3 = putField [True, False]} -- -- To serialize a message first convert it into a 'Data.Serialize.Put' by way of 'encodeMessage' -- and then to a 'Data.ByteString.ByteString' by using 'Data.Serialize.runPut'. Lazy -- 'Data.ByteString.Lazy.ByteString' serialization is done with 'Data.Serialize.runPutLazy'. -- -- >>> fmap hex runPut $ encodeMessage msg -- "082A18011800" -- -- Decoding is done with the inverse functions: 'decodeMessage' -- and 'Data.Serialize.runGet', or 'Data.Serialize.runGetLazy'. -- -- >>> runGet decodeMessage =<< unhex "082A18011800" :: Either String Foo -- Right -- (Foo -- { field1 = Field {runField = Required {runRequired = Always {runAlways = Value {runValue = 42}}}} -- , field2 = Field {runField = Optional {runOptional = Last {getLast = Nothing}}} -- , field3 = Field {runField = Repeated {runRepeated = [Value {runValue = True},Value {runValue = False}]}} -- } -- ) -- -- Use 'getField' to read fields from a message: -- -- >>> let Right msg = runGet decodeMessage =<< unhex "082A18011800" :: Either String Foo -- >>> getField $ field1 msg -- 42 -- >>> getField $ field2 msg -- Nothing -- >>> getField $ field3 msg -- [True,False] -- -- Some Protocol Buffers features are not currently implemented: -- -- * Default values for 'Optional' fields -- -- * Extension fields -- -- * Storing unknown fields, those without a mapped field tag in message record -- -- * Tag-delimited Groups, deprecated in lieu of 'Message' -- module Data.ProtocolBuffers ( -- * Message Serialization -- -- ** Encoding -- Encode(..) , encodeMessage , encodeLengthPrefixedMessage -- ** Decoding -- , Decode(..) , decodeMessage , decodeLengthPrefixedMessage -- * Fields -- -- ** Tags -- | -- -- Restricted type aliases of 'Field'. These are used to attach a field tag (a numeric id) to a field. -- Each tag must be unique within a given message, though this is not currently checked or enforced. -- , Required , Optional , Repeated , Packed -- ** Accessors -- | -- -- Fields tend to have rather complex types that are unpleasant to interact with. -- 'HasField' was designed to hide this complexity and provide a consistent way of -- getting and setting fields. -- , HasField(..) -- ** Selectors -- | -- -- Follow these rules to define fields supported by the generic encoder/decoder: -- -- * The 'n' phantom type parameter specifies the Protocol Buffers field tag (id). -- -- * Field tags /must/ be an instance of 'GHC.TypeLits.Nat'. -- -- * Field selectors /must/ be an instance of 'Data.Foldable.Foldable' to support encoding. -- -- * Value selectors /must/ be an instance of 'Data.Monoid.Monoid' to support decoding. -- , Field -- * Values -- -- ** Selectors -- | -- -- Each field value needs to specify the way it should be encoded. -- -- There are three built-in value selectors: 'Value', 'Enumeration' and 'Message'. -- -- If you're unsure what value selector to use, 'Value' is probably the correct one. -- , Value , Enumeration , Message -- * Wire Coding -- | -- -- Some primitive values can be more compactly represented. Fields that typically contain -- negative or very large numbers should use the 'Signed' or 'Fixed' wrappers to select -- their respective (efficient) formats. -- , Signed(..) , Fixed(..) ) where import Data.ProtocolBuffers.Decode import Data.ProtocolBuffers.Message import Data.ProtocolBuffers.Encode import Data.ProtocolBuffers.Types protobuf-0.2.1.3/src/Data/ProtocolBuffers/0000755000000000000000000000000007346545000016462 5ustar0000000000000000protobuf-0.2.1.3/src/Data/ProtocolBuffers/Decode.hs0000644000000000000000000001144207346545000020203 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module Data.ProtocolBuffers.Decode ( Decode(..) , decodeMessage , decodeLengthPrefixedMessage , GDecode(..) , fieldDecode ) where import Control.Applicative import Control.Monad import qualified Data.ByteString as B import Data.Foldable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Int (Int32, Int64) import Data.Maybe (fromMaybe) import Data.Monoid import Data.Proxy import Data.Serialize.Get import Data.Traversable (traverse) import GHC.Generics import GHC.TypeLits import Data.ProtocolBuffers.Types import Data.ProtocolBuffers.Wire -- | -- Decode a Protocol Buffers message. decodeMessage :: Decode a => Get a {-# INLINE decodeMessage #-} decodeMessage = decode =<< HashMap.map reverse <$> go HashMap.empty where go :: HashMap Tag [WireField] -> Get (HashMap Tag [WireField]) go msg = do mfield <- Just <$> getWireField <|> return Nothing case mfield of Just v -> go $! HashMap.insertWith (\(x:[]) xs -> x:xs) (wireFieldTag v) [v] msg Nothing -> return msg -- | -- Decode a Protocol Buffers message prefixed with a varint encoded 32-bit integer describing its length. decodeLengthPrefixedMessage :: Decode a => Get a {-# INLINE decodeLengthPrefixedMessage #-} decodeLengthPrefixedMessage = do len :: Int64 <- getVarInt bs <- getBytes $ fromIntegral len case runGetState decodeMessage bs 0 of Right (val, bs') | B.null bs' -> return val | otherwise -> fail $ "Unparsed bytes leftover in decodeLengthPrefixedMessage: " ++ show (B.length bs') Left err -> fail err class Decode (a :: *) where decode :: HashMap Tag [WireField] -> Get a default decode :: (Generic a, GDecode (Rep a)) => HashMap Tag [WireField] -> Get a decode = fmap to . gdecode -- | Untyped message decoding, @ 'decode' = 'id' @ instance Decode (HashMap Tag [WireField]) where decode = pure class GDecode (f :: * -> *) where gdecode :: HashMap Tag [WireField] -> Get (f a) instance GDecode a => GDecode (M1 i c a) where gdecode = fmap M1 . gdecode instance (GDecode a, GDecode b) => GDecode (a :*: b) where gdecode msg = liftA2 (:*:) (gdecode msg) (gdecode msg) instance (GDecode x, GDecode y) => GDecode (x :+: y) where gdecode msg = L1 <$> gdecode msg <|> R1 <$> gdecode msg fieldDecode :: forall a b i n p . (DecodeWire a, Monoid a, KnownNat n) => (a -> b) -> HashMap Tag [WireField] -> Get (K1 i (Field n b) p) {-# INLINE fieldDecode #-} fieldDecode c msg = let tag = fromIntegral $ natVal (Proxy :: Proxy n) in case HashMap.lookup tag msg of Just val -> K1 . Field . c <$> foldMapM decodeWire val Nothing -> empty instance (DecodeWire a, KnownNat n) => GDecode (K1 i (Field n (OptionalField (Last (Value a))))) where gdecode msg = fieldDecode Optional msg <|> pure (K1 mempty) instance (Enum a, KnownNat n) => GDecode (K1 i (Field n (RequiredField (Always (Enumeration a))))) where gdecode msg = do K1 mx <- fieldDecode Required msg case mx :: Field n (RequiredField (Always (Value Int32))) of Field (Required (Always (Value x))) -> return . K1 . Field . Required . Always . Enumeration . toEnum $ fromIntegral x instance (Enum a, KnownNat n) => GDecode (K1 i (Field n (OptionalField (Last (Enumeration a))))) where gdecode msg = do K1 mx <- fieldDecode Optional msg <|> pure (K1 mempty) case mx :: Field n (OptionalField (Last (Value Int32))) of Field (Optional (Last (Just (Value x)))) -> return . K1 . Field . Optional . Last . Just . Enumeration . toEnum $ fromIntegral x _ -> pure (K1 mempty) instance (DecodeWire a, KnownNat n) => GDecode (K1 i (Repeated n a)) where gdecode msg = let tag = fromIntegral $ natVal (Proxy :: Proxy n) in case HashMap.lookup tag msg of Just val -> K1 . Field . Repeated <$> traverse decodeWire val Nothing -> pure $ K1 mempty instance (DecodeWire a, KnownNat n) => GDecode (K1 i (Field n (RequiredField (Always (Value a))))) where gdecode msg = fieldDecode Required msg instance (DecodeWire (PackedList a), KnownNat n) => GDecode (K1 i (Packed n a)) where gdecode msg = fieldDecode PackedField msg <|> pure (K1 mempty) instance GDecode U1 where gdecode _ = return U1 -- | -- foldMapM implemented in a way that defers using (mempty :: b) unless the -- Foldable is empty, this allows the gross hack of pretending Always is -- a Monoid while strictly evaluating the accumulator foldMapM :: (Monad m, Foldable t, Monoid b) => (a -> m b) -> t a -> m b foldMapM f = liftM (fromMaybe mempty) . foldlM go Nothing where go (Just !acc) = liftM (Just . mappend acc) . f go Nothing = liftM Just . f protobuf-0.2.1.3/src/Data/ProtocolBuffers/Encode.hs0000644000000000000000000000370007346545000020213 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module Data.ProtocolBuffers.Encode ( Encode(..) , encodeMessage , encodeLengthPrefixedMessage , GEncode ) where import qualified Data.ByteString as B import Data.Foldable import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Proxy import Data.Serialize.Put import GHC.Generics import GHC.TypeLits import Data.ProtocolBuffers.Types import Data.ProtocolBuffers.Wire -- | -- Encode a Protocol Buffers message. encodeMessage :: Encode a => a -> Put encodeMessage = encode -- | -- Encode a Protocol Buffers message prefixed with a varint encoded 32-bit integer describing its length. encodeLengthPrefixedMessage :: Encode a => a -> Put {-# INLINE encodeLengthPrefixedMessage #-} encodeLengthPrefixedMessage msg = do let msg' = runPut $ encodeMessage msg putVarUInt $ B.length msg' putByteString msg' class Encode (a :: *) where encode :: a -> Put default encode :: (Generic a, GEncode (Rep a)) => a -> Put encode = gencode . from -- | Untyped message encoding instance Encode (HashMap Tag [WireField]) where encode = traverse_ step . HashMap.toList where step = uncurry (traverse_ . encodeWire) class GEncode (f :: * -> *) where gencode :: f a -> Put instance GEncode a => GEncode (M1 i c a) where gencode = gencode . unM1 instance (GEncode a, GEncode b) => GEncode (a :*: b) where gencode (x :*: y) = gencode x >> gencode y instance (GEncode a, GEncode b) => GEncode (a :+: b) where gencode (L1 x) = gencode x gencode (R1 y) = gencode y instance (EncodeWire a, KnownNat n, Foldable f) => GEncode (K1 i (Field n (f a))) where gencode = traverse_ (encodeWire tag) . runField . unK1 where tag = fromIntegral $ natVal (Proxy :: Proxy n) instance GEncode U1 where gencode _ = return () protobuf-0.2.1.3/src/Data/ProtocolBuffers/Internal.hs0000644000000000000000000000126107346545000020572 0ustar0000000000000000module Data.ProtocolBuffers.Internal ( Tag , WireField(..) , wireFieldTag , getWireField , EncodeWire(..) , DecodeWire(..) , zzEncode32 , zzEncode64 , zzDecode32 , zzDecode64 , getVarintPrefixedBS, getVarInt , putVarintPrefixedBS, putVarSInt, putVarUInt , Field(..) , Value(..) , Always(..) , Enumeration(..) , RequiredField(..) , OptionalField(..) , RepeatedField(..) , PackedField(..) , PackedList(..) , Message(..) , GDecode , GEncode , GMessageMonoid ) where import Data.ProtocolBuffers.Decode import Data.ProtocolBuffers.Encode import Data.ProtocolBuffers.Message import Data.ProtocolBuffers.Types import Data.ProtocolBuffers.Wire protobuf-0.2.1.3/src/Data/ProtocolBuffers/Message.hs0000644000000000000000000001524307346545000020407 0ustar0000000000000000{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} module Data.ProtocolBuffers.Message ( Message(..) , GMessageMonoid ) where import Control.Applicative import Control.DeepSeq (NFData(..)) import Data.Foldable import Data.Monoid hiding ((<>)) import Data.Serialize.Get import Data.Serialize.Put import Data.Traversable import Data.Semigroup (Semigroup(..)) import GHC.Generics import GHC.TypeLits import Data.ProtocolBuffers.Decode import Data.ProtocolBuffers.Encode import Data.ProtocolBuffers.Types import Data.ProtocolBuffers.Wire -- | -- The way to embed a message within another message. -- These embedded messages are stored as length-delimited fields. -- -- For example: -- -- @ --data Inner = Inner -- { innerField :: 'Data.ProtocolBuffers.Required' '1' ('Data.ProtocolBuffers.Value' 'Data.Int.Int64') -- } deriving ('GHC.Generics.Generic', 'Prelude.Show') -- -- instance 'Encode' Inner --instance 'Decode' Inner -- -- data Outer = Outer -- { outerField :: 'Data.ProtocolBuffers.Required' '1' ('Data.ProtocolBuffers.Message' Inner) -- } deriving ('GHC.Generics.Generic', 'Prelude.Show') -- -- instance 'Encode' Outer --instance 'Decode' Outer -- @ -- -- It's worth noting that @ 'Message' a @ is a 'Monoid' and 'NFData' instance. The 'Monoid' behavior models -- that of the Protocol Buffers documentation, effectively 'Data.Monoid.Last'. It's done with a fairly big hammer -- and it isn't possible to override this behavior. This can cause some less-obvious compile errors for -- paramterized 'Message' types: -- -- @ --data Inner = Inner{inner :: 'Required' '2' ('Value' 'Float')} deriving ('Generic', 'Show') --instance 'Encode' Inner --instance 'Decode' Inner -- --data Outer a = Outer{outer :: 'Required' '3' ('Message' a)} deriving ('Generic', 'Show') --instance 'Encode' a => 'Encode' (Outer a) --instance 'Decode' a => 'Decode' (Outer a) -- @ -- -- This fails because 'Decode' needs to know that the message can be merged. The resulting error -- implies that you may want to add a constraint to the internal 'GMessageMonoid' class: -- -- @ -- \/tmp\/tst.hs:18:10: -- Could not deduce (protobuf-0.1:'Data.ProtocolBuffers.Message.GMessageMonoid' ('Rep' a)) -- arising from a use of `protobuf-0.1: 'Data.ProtocolBuffers.Decode' .$gdmdecode' -- from the context ('Decode' a) -- bound by the instance declaration at \/tmp\/tst.hs:18:10-39 -- Possible fix: -- add an instance declaration for -- (protobuf-0.1:'Data.ProtocolBuffers.Message.GMessageMonoid' ('Rep' a)) -- In the expression: -- (protobuf-0.1:'Data.ProtocolBuffers.Decode'.$gdmdecode) -- In an equation for `decode': -- decode = (protobuf-0.1:'Data.ProtocolBuffers.Decode' .$gdmdecode) -- In the instance declaration for `'Decode' (Outer a)' -- @ -- -- The correct fix is to add the 'Monoid' constraint for the message: -- -- @ -- - instance ('Encode' a) => 'Decode' (Outer a) -- + instance ('Monoid' ('Message' a), 'Decode' a) => 'Decode' (Outer a) -- @ -- newtype Message m = Message {runMessage :: m} deriving (Eq, Foldable, Functor, Ord, Show, Traversable) instance (Generic m, GMessageMonoid (Rep m)) => Semigroup (Message m) where Message x <> Message y = Message . to $ gmappend (from x) (from y) instance (Generic m, GMessageMonoid (Rep m)) => Monoid (Message m) where mempty = Message . to $ gmempty mappend = (<>) instance (Decode a, Monoid (Message a), KnownNat n) => GDecode (K1 i (Field n (RequiredField (Always (Message a))))) where gdecode = fieldDecode (Required . Always) instance (Decode a, Monoid (Message a), KnownNat n) => GDecode (K1 i (Field n (OptionalField (Maybe (Message a))))) where gdecode msg = fieldDecode (Optional . Just) msg <|> pure (K1 mempty) class GMessageMonoid (f :: * -> *) where gmempty :: f a gmappend :: f a -> f a -> f a instance GMessageMonoid f => GMessageMonoid (M1 i c f) where gmempty = M1 gmempty gmappend (M1 x) (M1 y) = M1 (gmappend x y) instance (GMessageMonoid x, GMessageMonoid y) => GMessageMonoid (x :*: y) where gmempty = gmempty :*: gmempty gmappend (x1 :*: x2) (y1 :*: y2) = gmappend x1 y1 :*: gmappend x2 y2 instance (GMessageMonoid x, GMessageMonoid y) => GMessageMonoid (x :+: y) where gmempty = L1 gmempty gmappend _ = id instance (Monoid c) => GMessageMonoid (K1 i c) where gmempty = K1 mempty gmappend (K1 x) (K1 y) = K1 $ mappend x y instance GMessageMonoid U1 where gmempty = U1 gmappend _ = id instance (Generic m, GMessageNFData (Rep m)) => NFData (Message m) where rnf = grnf . from . runMessage class GMessageNFData f where grnf :: f a -> () instance GMessageNFData f => GMessageNFData (M1 i c f) where grnf = grnf . unM1 instance (GMessageNFData x, GMessageNFData y) => GMessageNFData (x :*: y) where grnf (x :*: y) = grnf x `seq` grnf y instance (GMessageNFData x, GMessageNFData y) => GMessageNFData (x :+: y) where grnf (L1 x) = grnf x grnf (R1 y) = grnf y instance NFData c => GMessageNFData (K1 i c) where grnf = rnf . unK1 instance GMessageNFData U1 where grnf U1 = () type instance Optional n (Message a) = Field n (OptionalField (Maybe (Message a))) type instance Required n (Message a) = Field n (RequiredField (Always (Message a))) instance (Foldable f, Encode m) => EncodeWire (f (Message m)) where encodeWire t = traverse_ (encodeWire t . runPut . encode . runMessage) instance Decode m => DecodeWire (Message m) where decodeWire (DelimitedField _ bs) = case runGet decodeMessage bs of Right val -> pure $ Message val Left err -> fail $ "Embedded message decoding failed: " ++ show err decodeWire _ = empty -- | Iso: @ 'FieldType' ('Required' n ('Message' a)) = a @ instance HasField (Field n (RequiredField (Always (Message a)))) where type FieldType (Field n (RequiredField (Always (Message a)))) = a getField = runMessage . runAlways. runRequired . runField putField = Field . Required . Always . Message -- | Iso: @ 'FieldType' ('Optional' n ('Message' a)) = 'Maybe' a @ instance HasField (Field n (OptionalField (Maybe (Message a)))) where type FieldType (Field n (OptionalField (Maybe (Message a)))) = Maybe a getField = fmap runMessage . runOptional . runField putField = Field . Optional . fmap Message -- | Iso: @ 'FieldType' ('Repeated' n ('Message' a)) = [a] @ instance HasField (Field n (RepeatedField [Message a])) where type FieldType (Field n (RepeatedField [Message a])) = [a] getField = fmap runMessage . runRepeated . runField putField = Field . Repeated . fmap Message protobuf-0.2.1.3/src/Data/ProtocolBuffers/Orphans.hs0000644000000000000000000000051707346545000020433 0ustar0000000000000000-- | -- Messages containing 'Optional' 'Enumeration' fields fail to encode. -- This module contains orphan instances required to make these functional. -- -- For more information reference the associated ticket: -- module Data.ProtocolBuffers.Orphans () where import Data.Orphans () protobuf-0.2.1.3/src/Data/ProtocolBuffers/Types.hs0000644000000000000000000002063307346545000020126 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} module Data.ProtocolBuffers.Types ( Field(..) , HasField(..) , Required , RequiredField(..) , Optional , OptionalField(..) , Repeated , RepeatedField(..) , Packed , Value(..) , Enumeration(..) , Fixed(..) , Signed(..) , Always(..) , PackedList(..) , PackedField(..) ) where import Control.DeepSeq (NFData) import Data.Bits import Data.Foldable as Fold import Data.Monoid hiding ((<>)) import Data.Semigroup (Semigroup(..)) import Data.Traversable import Data.Typeable import GHC.TypeLits -- | -- 'Value' selects the normal/typical way for encoding scalar (primitive) values. newtype Value a = Value {runValue :: a} deriving (Bounded, Eq, Enum, Foldable, Functor, Semigroup, Monoid, Ord, NFData, Show, Traversable, Typeable) -- | -- 'RequiredField' is a newtype wrapped used to break overlapping instances -- for encoding and decoding values newtype RequiredField a = Required {runRequired :: a} deriving (Bounded, Eq, Enum, Foldable, Functor, Semigroup, Monoid, Ord, NFData, Show, Traversable, Typeable) -- | -- 'OptionalField' is a newtype wrapped used to break overlapping instances -- for encoding and decoding values newtype OptionalField a = Optional {runOptional :: a} deriving (Bounded, Eq, Enum, Foldable, Functor, Semigroup, Monoid, Ord, NFData, Show, Traversable, Typeable) -- | -- 'RepeatedField' is a newtype wrapped used to break overlapping instances -- for encoding and decoding values newtype RepeatedField a = Repeated {runRepeated :: a} deriving (Bounded, Eq, Enum, Foldable, Functor, Semigroup, Monoid, Ord, NFData, Show, Traversable, Typeable) -- | -- Fields are merely a way to hold a field tag along with its type, this shouldn't normally be referenced directly. -- -- This provides better error messages than older versions which used 'Data.Tagged.Tagged' -- newtype Field (n :: Nat) a = Field {runField :: a} deriving (Bounded, Eq, Enum, Foldable, Functor, Semigroup, Monoid, Ord, NFData, Show, Traversable, Typeable) -- | -- To provide consistent instances for serialization a 'Traversable' 'Functor' is needed to -- make 'Required' fields have the same shape as 'Optional', 'Repeated' and 'Packed'. -- -- This is the 'Data.Functor.Identity.Identity' 'Functor' with a 'Show' instance. newtype Always a = Always {runAlways :: a} deriving (Bounded, Eq, Enum, Foldable, Functor, Ord, NFData, Show, Traversable, Typeable) instance Semigroup (Always a) where _ <> y = y instance Monoid (Always a) where mempty = error "Always is not a Monoid" mappend = (<>) -- | -- Functions for wrapping and unwrapping record fields. -- When applied they will have types similar to these: -- -- @ --'getField' :: 'Required' '1' ('Value' 'Data.Text.Text') -> 'Data.Text.Text' --'putField' :: 'Data.Text.Text' -> 'Required' '1' ('Value' 'Data.Text.Text') -- --'getField' :: 'Optional' '2' ('Value' 'Data.Int.Int32') -> 'Maybe' 'Data.Int.Int32' --'putField' :: 'Maybe' 'Data.Int.Int32' -> 'Optional' '2' ('Value' 'Data.Int.Int32') -- --'getField' :: 'Repeated' '3' ('Value' 'Double') -> ['Double'] --'putField' :: ['Double'] -> 'Repeated' '3' ('Value' 'Double') -- --'getField' :: 'Packed' '4' ('Value' 'Data.Word.Word64') -> ['Data.Word.Word64'] --'putField' :: ['Data.Word.Word64'] -> 'Packed' '4' ('Value' 'Data.Word.Word64') -- @ class HasField a where type FieldType a :: * -- | Extract a value from it's 'Field' representation. getField :: a -> FieldType a -- | Wrap it back up again. putField :: FieldType a -> a -- | An isomorphism lens compatible with the lens package field :: Functor f => (FieldType a -> f (FieldType a)) -> a -> f a field f = fmap putField . f . getField -- | Iso: @ 'FieldType' ('Required' n ('Value' a)) = a @ instance HasField (Field n (RequiredField (Always (Value a)))) where type FieldType (Field n (RequiredField (Always (Value a)))) = a getField = runValue . runAlways . runRequired . runField putField = Field . Required . Always . Value -- | Iso: @ 'FieldType' ('Required' n ('Enumeration' a)) = a @ instance HasField (Field n (RequiredField (Always (Enumeration a)))) where type FieldType (Field n (RequiredField (Always (Enumeration a)))) = a getField = runEnumeration . runAlways . runRequired . runField putField = Field . Required . Always . Enumeration -- | Iso: @ 'FieldType' ('Optional' n ('Value' a)) = 'Maybe' a @ instance HasField (Field n (OptionalField (Last (Value a)))) where type FieldType (Field n (OptionalField (Last (Value a)))) = Maybe a getField = fmap runValue . getLast . runOptional . runField putField = Field . Optional . Last . fmap Value -- | Iso: @ 'FieldType' ('Optional' n ('Enumeration' a)) = 'Maybe' a @ instance HasField (Field n (OptionalField (Last (Enumeration a)))) where type FieldType (Field n (OptionalField (Last (Enumeration a)))) = Maybe a getField = fmap runEnumeration . getLast . runOptional . runField putField = Field . Optional . Last . fmap Enumeration -- | Iso: @ 'FieldType' ('Repeated' n ('Value' a)) = [a] @ instance HasField (Field n (RepeatedField [Value a])) where type FieldType (Field n (RepeatedField [Value a])) = [a] getField = fmap runValue . runRepeated . runField putField = Field . Repeated . fmap Value -- | Iso: @ 'FieldType' ('Repeated' n ('Enumeration' a)) = [a] @ instance HasField (Field n (RepeatedField [Enumeration a])) where type FieldType (Field n (RepeatedField [Enumeration a])) = [a] getField = fmap runEnumeration . runRepeated . runField putField = Field . Repeated . fmap Enumeration -- | Iso: @ 'FieldType' ('Packed' n ('Value' a)) = [a] @ instance HasField (Field n (PackedField (PackedList (Value a)))) where type FieldType (Field n (PackedField (PackedList (Value a)))) = [a] getField = fmap runValue . unPackedList . runPackedField . runField putField = Field . PackedField . PackedList . fmap Value -- | Iso: @ 'FieldType' ('Packed' n ('Enumeration' a)) = [a] @ instance HasField (Field n (PackedField (PackedList (Enumeration a)))) where type FieldType (Field n (PackedField (PackedList (Enumeration a)))) = [a] getField = fmap runEnumeration . unPackedList . runPackedField . runField putField = Field . PackedField . PackedList . fmap Enumeration -- | Optional fields. Values that are not found will return 'Nothing'. type family Optional (n :: Nat) (a :: *) :: * type instance Optional n (Value a) = Field n (OptionalField (Last (Value a))) type instance Optional n (Enumeration a) = Field n (OptionalField (Last (Enumeration a))) -- | Required fields. Parsing will return 'Control.Alternative.empty' if a 'Required' value is not found while decoding. type family Required (n :: Nat) (a :: *) :: * type instance Required n (Value a) = Field n (RequiredField (Always (Value a))) type instance Required n (Enumeration a) = Field n (RequiredField (Always (Enumeration a))) -- | Lists of values. type Repeated n a = Field n (RepeatedField [a]) -- | Packed values. type Packed n a = Field n (PackedField (PackedList a)) -- | -- 'Enumeration' fields use 'Prelude.fromEnum' and 'Prelude.toEnum' when encoding and decoding messages. newtype Enumeration a = Enumeration {runEnumeration :: a} deriving (Bounded, Eq, Enum, Foldable, Functor, Ord, Semigroup, Monoid, NFData, Show, Traversable, Typeable) -- | -- A 'Traversable' 'Functor' used to select packed sequence encoding/decoding. newtype PackedField a = PackedField {runPackedField :: a} deriving (Eq, Foldable, Functor, Semigroup, Monoid, NFData, Ord, Show, Traversable, Typeable) -- | -- A list that is stored in a packed format. newtype PackedList a = PackedList {unPackedList :: [a]} deriving (Eq, Foldable, Functor, Semigroup, Monoid, NFData, Ord, Show, Traversable, Typeable) -- | -- Signed integers are stored in a zz-encoded form. newtype Signed a = Signed a deriving (Bits, Bounded, Enum, Eq, Floating, Foldable, Fractional, Functor, Integral, Semigroup, Monoid, NFData, Num, Ord, Real, RealFloat, RealFrac, Show, Traversable, Typeable) -- | -- Fixed integers are stored in little-endian form without additional encoding. newtype Fixed a = Fixed a deriving (Bits, Bounded, Enum, Eq, Floating, Foldable, Fractional, Functor, Integral, Semigroup, Monoid, NFData, Num, Ord, Real, RealFloat, RealFrac, Show, Traversable, Typeable) protobuf-0.2.1.3/src/Data/ProtocolBuffers/Wire.hs0000644000000000000000000003732207346545000017733 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} module Data.ProtocolBuffers.Wire ( Enumeration(..) , WireField(..) , Tag , EncodeWire(..) , DecodeWire(..) , wireFieldTag , getWireField , getVarInt , getVarintPrefixedBS , putVarSInt , putVarUInt , putVarintPrefixedBS , zzEncode32 , zzEncode64 , zzDecode32 , zzDecode64 ) where import Control.Applicative import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.Foldable import Data.Int import Data.Monoid import Data.Serialize.Get import Data.Serialize.IEEE754 import Data.Serialize.Put import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Typeable import Data.Word import Data.Binary.IEEE754 (wordToDouble, wordToFloat) import Data.ProtocolBuffers.Types -- | -- Field identifiers type Tag = Word32 -- | -- A representation of the wire format as described in -- data WireField = VarintField {-# UNPACK #-} !Tag {-# UNPACK #-} !Word64 -- ^ For: int32, int64, uint32, uint64, sint32, sint64, bool, enum | Fixed64Field {-# UNPACK #-} !Tag {-# UNPACK #-} !Word64 -- ^ For: fixed64, sfixed64, double | DelimitedField {-# UNPACK #-} !Tag !ByteString -- ^ For: string, bytes, embedded messages, packed repeated fields | StartField {-# UNPACK #-} !Tag -- ^ For: groups (deprecated) | EndField {-# UNPACK #-} !Tag -- ^ For: groups (deprecated) | Fixed32Field {-# UNPACK #-} !Tag {-# UNPACK #-} !Word32 -- ^ For: fixed32, sfixed32, float deriving (Eq, Ord, Show, Typeable) getVarintPrefixedBS :: Get ByteString getVarintPrefixedBS = getBytes =<< getVarInt putVarintPrefixedBS :: ByteString -> Put putVarintPrefixedBS bs = putVarUInt (B.length bs) >> putByteString bs getWireField :: Get WireField getWireField = do wireTag <- getVarInt let tag = wireTag `shiftR` 3 case wireTag .&. 7 of 0 -> VarintField tag <$> getVarInt 1 -> Fixed64Field tag <$> getWord64le 2 -> DelimitedField tag <$> getVarintPrefixedBS 3 -> return $! StartField tag 4 -> return $! EndField tag 5 -> Fixed32Field tag <$> getWord32le x -> fail $ "Wire type out of range: " ++ show x putWireField :: WireField -> Put putWireField (VarintField t val) = putWireTag t 0 >> putVarUInt val putWireField (Fixed64Field t val) = putWireTag t 1 >> putWord64le val putWireField (DelimitedField t val) = putWireTag t 2 >> putVarintPrefixedBS val putWireField (StartField t ) = putWireTag t 3 putWireField (EndField t ) = putWireTag t 4 putWireField (Fixed32Field t val) = putWireTag t 5 >> putWord32le val putWireTag :: Tag -> Word32 -> Put putWireTag tag typ | tag <= 0x1FFFFFFF, typ <= 7 = putVarUInt $ tag `shiftL` 3 .|. (typ .&. 7) | tag > 0x1FFFFFFF = legacyFail $ "Wire tag out of range: " ++ show tag | otherwise = legacyFail $ "Wire type out of range: " ++ show typ getVarInt :: (Integral a, Bits a) => Get a getVarInt = go 0 0 where go n !val = do b <- getWord8 if testBit b 7 then go (n+7) (val .|. (fromIntegral (b .&. 0x7F) `shiftL` n)) else return $! val .|. (fromIntegral b `shiftL` n) -- | This can be used on any Integral type and is needed for signed types; unsigned can use putVarUInt below. -- This has been changed to handle only up to 64 bit integral values (to match documentation). {-# INLINE putVarSInt #-} putVarSInt :: (Integral a, Bits a) => a -> Put putVarSInt bIn = case compare bIn 0 of LT -> let -- upcast to 64 bit to match documentation of 10 bytes for all negative values b = fromIntegral bIn len = 10 -- (pred 10)*7 < 64 <= 10*7 last'Mask = 1 -- pred (1 `shiftL` 1) go :: Int64 -> Int -> Put go !i 1 = putWord8 (fromIntegral (i .&. last'Mask)) go !i n = putWord8 (fromIntegral (i .&. 0x7F) .|. 0x80) >> go (i `shiftR` 7) (pred n) in go b len EQ -> putWord8 0 GT -> putVarUInt bIn -- | This should be used on unsigned Integral types only (not checked) {-# INLINE putVarUInt #-} putVarUInt :: (Integral a, Bits a) => a -> Put putVarUInt i | i < 0x80 = putWord8 (fromIntegral i) | otherwise = putWord8 (fromIntegral (i .&. 0x7F) .|. 0x80) >> putVarUInt (i `shiftR` 7) wireFieldTag :: WireField -> Tag wireFieldTag f = case f of VarintField t _ -> t Fixed64Field t _ -> t DelimitedField t _ -> t StartField t -> t EndField t -> t Fixed32Field t _ -> t class EncodeWire a where encodeWire :: Tag -> a -> Put class DecodeWire a where decodeWire :: WireField -> Get a deriving instance EncodeWire a => EncodeWire (Always (Value a)) deriving instance EncodeWire a => EncodeWire (Last (Value a)) deriving instance DecodeWire a => DecodeWire (Always (Value a)) deriving instance DecodeWire a => DecodeWire (Last (Value a)) instance EncodeWire a => EncodeWire [Value a] where encodeWire t = traverse_ (encodeWire t) instance EncodeWire WireField where encodeWire t f | t == wireFieldTag f = putWireField f | otherwise = legacyFail "Specified tag and field tag do not match" instance DecodeWire WireField where decodeWire = pure instance EncodeWire a => EncodeWire (Value a) where encodeWire t = traverse_ (encodeWire t) instance DecodeWire a => DecodeWire (Value a) where decodeWire = fmap Value . decodeWire instance EncodeWire a => EncodeWire (Maybe (Value a)) where encodeWire t = traverse_ (encodeWire t) instance DecodeWire a => DecodeWire (Maybe (Value a)) where decodeWire = fmap (Just . Value) . decodeWire instance EncodeWire Int32 where encodeWire t val = putWireTag t 0 >> putVarSInt val instance DecodeWire Int32 where decodeWire (VarintField _ val) = pure $ fromIntegral val decodeWire _ = empty instance EncodeWire Int64 where encodeWire t val = putWireTag t 0 >> putVarSInt val instance DecodeWire Int64 where decodeWire (VarintField _ val) = pure $ fromIntegral val decodeWire _ = empty instance EncodeWire Word32 where encodeWire t val = putWireTag t 0 >> putVarUInt val instance DecodeWire Word32 where decodeWire (VarintField _ val) = pure $ fromIntegral val decodeWire _ = empty instance EncodeWire Word64 where encodeWire t val = putWireTag t 0 >> putVarUInt val instance DecodeWire Word64 where decodeWire (VarintField _ val) = pure val decodeWire _ = empty instance EncodeWire (Signed Int32) where encodeWire t (Signed val) = putWireTag t 0 >> putVarSInt (zzEncode32 val) instance DecodeWire (Signed Int32) where decodeWire (VarintField _ val) = pure . Signed . zzDecode32 $ fromIntegral val decodeWire _ = empty instance EncodeWire (Signed Int64) where encodeWire t (Signed val) = putWireTag t 0 >> putVarSInt (zzEncode64 val) instance DecodeWire (Signed Int64) where decodeWire (VarintField _ val) = pure . Signed . zzDecode64 $ fromIntegral val decodeWire _ = empty instance EncodeWire (Fixed Int32) where encodeWire t (Fixed val) = putWireTag t 5 >> putWord32le (fromIntegral val) instance DecodeWire (Fixed Int32) where decodeWire (Fixed32Field _ val) = pure . Fixed $ fromIntegral val decodeWire _ = empty instance EncodeWire (Fixed Int64) where encodeWire t (Fixed val) = putWireTag t 1 >> putWord64le (fromIntegral val) instance DecodeWire (Fixed Int64) where decodeWire (Fixed64Field _ val) = pure . Fixed $ fromIntegral val decodeWire _ = empty instance EncodeWire (Fixed Word32) where encodeWire t (Fixed val) = putWireTag t 5 >> putWord32le val instance DecodeWire (Fixed Word32) where decodeWire (Fixed32Field _ val) = pure $ Fixed val decodeWire _ = empty instance EncodeWire (Fixed Word64) where encodeWire t (Fixed val) = putWireTag t 1 >> putWord64le val instance DecodeWire (Fixed Word64) where decodeWire (Fixed64Field _ val) = pure $ Fixed val decodeWire _ = empty instance EncodeWire Bool where encodeWire t val = putWireTag t 0 >> putVarUInt (if val then 1 else (0 :: Int32)) instance DecodeWire Bool where decodeWire (VarintField _ val) = pure $ val /= 0 decodeWire _ = empty instance EncodeWire Float where encodeWire t val = putWireTag t 5 >> putFloat32le val instance DecodeWire Float where decodeWire (Fixed32Field _ val) = pure $ wordToFloat val decodeWire _ = empty instance EncodeWire Double where encodeWire t val = putWireTag t 1 >> putFloat64le val instance DecodeWire Double where decodeWire (Fixed64Field _ val) = pure $ wordToDouble val decodeWire _ = empty instance EncodeWire ByteString where encodeWire t val = putWireTag t 2 >> putVarUInt (B.length val) >> putByteString val instance DecodeWire ByteString where decodeWire (DelimitedField _ bs) = pure bs decodeWire _ = empty instance EncodeWire String where encodeWire t = encodeWire t . T.pack instance DecodeWire String where decodeWire = fmap T.unpack . decodeWire instance EncodeWire T.Text where encodeWire t = encodeWire t . T.encodeUtf8 instance DecodeWire T.Text where decodeWire (DelimitedField _ bs) = case T.decodeUtf8' bs of Right val -> pure val Left err -> fail $ "Decoding failed: " ++ show err decodeWire _ = empty decodePackedList :: Get a -> WireField -> Get [a] {-# INLINE decodePackedList #-} decodePackedList g (DelimitedField _ bs) = case runGet (many g) bs of Right val -> return val Left err -> fail err decodePackedList _ _ = empty -- | -- Empty lists are not written out encodePackedList :: Tag -> Put -> Put {-# INLINE encodePackedList #-} encodePackedList t p | bs <- runPut p , not (B.null bs) = encodeWire t bs | otherwise = pure () instance EncodeWire (PackedList (Value Int32)) where encodeWire t (PackedList xs) = encodePackedList t $ traverse_ (putVarSInt . runValue) xs instance DecodeWire (PackedList (Value Int32)) where decodeWire x = do xs <- decodePackedList getVarInt x return . PackedList $ Value <$> xs instance EncodeWire (PackedList (Value Int64)) where encodeWire t (PackedList xs) = encodePackedList t $ traverse_ (putVarSInt . runValue) xs instance DecodeWire (PackedList (Value Int64)) where decodeWire x = do xs <- decodePackedList getVarInt x return . PackedList $ Value <$> xs instance EncodeWire (PackedList (Value Word32)) where encodeWire t (PackedList xs) = encodePackedList t $ traverse_ (putVarUInt . runValue) xs instance DecodeWire (PackedList (Value Word32)) where decodeWire x = do xs <- decodePackedList getVarInt x return . PackedList $ Value <$> xs instance EncodeWire (PackedList (Value Word64)) where encodeWire t (PackedList xs) = encodePackedList t $ traverse_ (putVarUInt . runValue) xs instance DecodeWire (PackedList (Value Word64)) where decodeWire x = do xs <- decodePackedList getVarInt x return . PackedList $ Value <$> xs instance EncodeWire (PackedList (Value (Signed Int32))) where encodeWire t (PackedList xs) = do let c (Signed x) = putVarSInt $ zzEncode32 x encodePackedList t $ traverse_ (c . runValue) xs instance DecodeWire (PackedList (Value (Signed Int32))) where decodeWire x = do xs <- decodePackedList getVarInt x return . PackedList $ Value . Signed . zzDecode32 <$> xs instance EncodeWire (PackedList (Value (Signed Int64))) where encodeWire t (PackedList xs) = do let c (Signed x) = putVarSInt $ zzEncode64 x encodePackedList t $ traverse_ (c . runValue) xs instance DecodeWire (PackedList (Value (Signed Int64))) where decodeWire x = do xs <- decodePackedList getVarInt x return . PackedList $ Value . Signed . zzDecode64 <$> xs instance EncodeWire (PackedList (Value (Fixed Word32))) where encodeWire t (PackedList xs) = do let c (Fixed x) = putWord32le x encodePackedList t $ traverse_ (c . runValue) xs instance DecodeWire (PackedList (Value (Fixed Word32))) where decodeWire x = do xs <- decodePackedList getWord32le x return . PackedList $ Value . Fixed <$> xs instance EncodeWire (PackedList (Value (Fixed Word64))) where encodeWire t (PackedList xs) = do let c (Fixed x) = putWord64le x encodePackedList t $ traverse_ (c . runValue) xs instance DecodeWire (PackedList (Value (Fixed Word64))) where decodeWire x = do xs <- decodePackedList getWord64le x return . PackedList $ Value . Fixed <$> xs instance EncodeWire (PackedList (Value (Fixed Int32))) where encodeWire t (PackedList xs) = do let c (Fixed x) = putWord32le $ fromIntegral x encodePackedList t $ traverse_ (c . runValue) xs instance DecodeWire (PackedList (Value (Fixed Int32))) where decodeWire x = do xs <- decodePackedList getWord32le x return . PackedList $ Value . Fixed . fromIntegral <$> xs instance EncodeWire (PackedList (Value (Fixed Int64))) where encodeWire t (PackedList xs) = do let c (Fixed x) = putWord64le $ fromIntegral x encodePackedList t $ traverse_ (c . runValue) xs instance DecodeWire (PackedList (Value (Fixed Int64))) where decodeWire x = do xs <- decodePackedList getWord64le x return . PackedList $ Value . Fixed . fromIntegral <$> xs instance EncodeWire (PackedList (Value Float)) where encodeWire t (PackedList xs) = encodePackedList t $ traverse_ (putFloat32le . runValue) xs instance DecodeWire (PackedList (Value Float)) where decodeWire x = do xs <- decodePackedList getFloat32le x return . PackedList $ Value <$> xs instance EncodeWire (PackedList (Value Double)) where encodeWire t (PackedList xs) = encodePackedList t $ traverse_ (putFloat64le . runValue) xs instance DecodeWire (PackedList (Value Double)) where decodeWire x = do xs <- decodePackedList getFloat64le x return . PackedList $ Value <$> xs instance EncodeWire (PackedList (Value Bool)) where encodeWire t (PackedList xs) = encodePackedList t $ traverse_ (putVarUInt . fromEnum) xs instance DecodeWire (PackedList (Value Bool)) where decodeWire x = do xs <- decodePackedList getVarInt x return . PackedList $ toEnum <$> xs instance Enum a => EncodeWire (PackedList (Enumeration a)) where encodeWire t (PackedList xs) = encodePackedList t $ traverse_ (putVarUInt . fromEnum) xs instance Enum a => DecodeWire (PackedList (Enumeration a)) where decodeWire x = do xs <- decodePackedList getVarInt x return . PackedList $ toEnum <$> xs instance (Foldable f, Enum a) => EncodeWire (f (Enumeration a)) where encodeWire t = traverse_ (encodeWire t . c . runEnumeration) where c :: a -> Int32 c = fromIntegral . fromEnum instance Enum a => DecodeWire (Enumeration a) where decodeWire f = c <$> decodeWire f where c :: Int32 -> Enumeration a c = Enumeration . toEnum . fromIntegral instance Enum a => DecodeWire (Maybe (Enumeration a)) where decodeWire f = c <$> decodeWire f where c :: Int32 -> Maybe (Enumeration a) c = Just . Enumeration . toEnum . fromIntegral instance Enum a => DecodeWire (Always (Enumeration a)) where decodeWire f = c <$> decodeWire f where c :: Int32 -> Always (Enumeration a) c = Always . Enumeration . toEnum . fromIntegral -- Taken from google's code, but I had to explcitly add fromIntegral in the right places: zzEncode32 :: Int32 -> Word32 zzEncode32 x = fromIntegral ((x `shiftL` 1) `xor` x `shiftR` 31) zzEncode64 :: Int64 -> Word64 zzEncode64 x = fromIntegral ((x `shiftL` 1) `xor` x `shiftR` 63) zzDecode32 :: Word32 -> Int32 zzDecode32 w = fromIntegral (w `shiftR` 1) `xor` negate (fromIntegral (w .&. 1)) zzDecode64 :: Word64 -> Int64 zzDecode64 w = fromIntegral (w `shiftR` 1) `xor` negate (fromIntegral (w .&. 1)) legacyFail :: Monad m => String -> m a #if __GLASGOW_HASKELL__ <= 710 legacyFail = fail #else legacyFail = errorWithoutStackTrace #endif protobuf-0.2.1.3/tests/0000755000000000000000000000000007346545000013046 5ustar0000000000000000protobuf-0.2.1.3/tests/Main.hs0000644000000000000000000006070107346545000014272 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} import Test.QuickCheck import Test.QuickCheck.Property hiding (testCase) import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import GHC.Generics import GHC.TypeLits import Control.Applicative import Control.Exception (SomeException, evaluate, try) import Control.Monad import qualified Data.ByteString as B import Data.ByteString.Char8 () import Data.ProtocolBuffers as Pb import Data.ProtocolBuffers.Internal as Pb import Data.ProtocolBuffers.Orphans () import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Hex import Data.Int import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import Data.Monoid import Data.Serialize (Get, Putter, runGet, runPut) import Data.Proxy import Data.Text (Text) import Data.Typeable import Data.Word main :: IO () main = defaultMain tests data EnumFoo = EnumFoo1 | EnumFoo2 | EnumFoo3 deriving (Bounded, Enum, Eq, Typeable) tests :: TestTree tests = testGroup "Root" [ testGroup "Primitive Wire" primitiveWireTests , testGroup "Packed Wire" packedWireTests , testGroup "Required Single Values" requiredSingleValueTests , testGroup "Optional Single Values" optionalSingleValueTests , testGroup "Repeated Single Values" repeatedSingleValueTests -- TODO Fix and re-enable --, testGroup "Tags Out of Range" tagsOutOfRangeTests , testProperty "Generic message coding" prop_generic , testProperty "Generic length prefixed message coding" prop_generic_length_prefixed , testProperty "Varint prefixed bytestring" prop_varint_prefixed_bytestring , testProperty "Random message" prop_message , testCase "Google Reference Test1" test1 , testCase "Google Reference Test2" test2 , testCase "Google Reference Test3" test3 , testCase "Google Reference Test4" test4 , testCase "Packed empty fields" test4_empty , testCase "Optional Enum Test5: Nothing" test5 , testCase "Optional Enum Test5: Just Test5A" test6 , testCase "Optional Enum Test5: Just Test5B" test7 , testCase "Repeated Enum Test6: []" test8 , testCase "Repeated Enum Test6: [Test6A]" test9 , testCase "Repeated Enum Test6: [Test6A, Test6B]" test10 , testCase "Repeated Enum Test6: [Test6A, Test6A]" test11 , testCase "Repeated Enum Test6: [Test6A, Test6B, Test6A]" test12 , testCase "Repeated Enum Test7: []" test13 , testCase "Repeated Enum Test7: [Test7]" test14 , testCase "Repeated Enum Test7: [Test7, Test7]" test15 , testCase "Google WireFormatTest ZigZag" wireFormatZZ ] primitiveTests :: (forall a . (Eq a, Typeable a, Arbitrary a, EncodeWire a, DecodeWire a) => Proxy a -> Property) -> [TestTree] primitiveTests f = [ testProperty "int32" (f (Proxy :: Proxy Int32)) , testProperty "int64" (f (Proxy :: Proxy Int64)) , testProperty "word32" (f (Proxy :: Proxy Word32)) , testProperty "word64" (f (Proxy :: Proxy Word64)) , testProperty "sint32" (f (Proxy :: Proxy (Signed Int32))) , testProperty "sint64" (f (Proxy :: Proxy (Signed Int64))) , testProperty "fixed32" (f (Proxy :: Proxy (Pb.Fixed Word32))) , testProperty "fixed64" (f (Proxy :: Proxy (Pb.Fixed Word64))) , testProperty "sfixed32" (f (Proxy :: Proxy (Pb.Fixed Int32))) , testProperty "sfixed64" (f (Proxy :: Proxy (Pb.Fixed Int64))) , testProperty "float" (f (Proxy :: Proxy Float)) , testProperty "double" (f (Proxy :: Proxy Double)) , testProperty "bool" (f (Proxy :: Proxy Bool)) , testProperty "enum" (f (Proxy :: Proxy (Always (Enumeration EnumFoo)))) ] primitiveWireTests :: [TestTree] primitiveWireTests = primitiveTests prop_wire packedWireTests :: [TestTree] packedWireTests = [ testProperty "int32" (prop_wire (Proxy :: Proxy (PackedList (Value Int32)))) , testProperty "int64" (prop_wire (Proxy :: Proxy (PackedList (Value Int64)))) , testProperty "word32" (prop_wire (Proxy :: Proxy (PackedList (Value Word32)))) , testProperty "word64" (prop_wire (Proxy :: Proxy (PackedList (Value Word64)))) , testProperty "sint32" (prop_wire (Proxy :: Proxy (PackedList (Value (Signed Int32))))) , testProperty "sint64" (prop_wire (Proxy :: Proxy (PackedList (Value (Signed Int64))))) , testProperty "fixed32" (prop_wire (Proxy :: Proxy (PackedList (Value (Pb.Fixed Word32))))) , testProperty "fixed64" (prop_wire (Proxy :: Proxy (PackedList (Value (Pb.Fixed Word64))))) , testProperty "sfixed32" (prop_wire (Proxy :: Proxy (PackedList (Value (Pb.Fixed Int32))))) , testProperty "sfixed64" (prop_wire (Proxy :: Proxy (PackedList (Value (Pb.Fixed Int64))))) , testProperty "float" (prop_wire (Proxy :: Proxy (PackedList (Value Float)))) , testProperty "double" (prop_wire (Proxy :: Proxy (PackedList (Value Double)))) , testProperty "bool" (prop_wire (Proxy :: Proxy (PackedList (Value Bool)))) ] requiredSingleValueTests :: [TestTree] requiredSingleValueTests = primitiveTests prop_req optionalSingleValueTests :: [TestTree] optionalSingleValueTests = primitiveTests prop_opt repeatedSingleValueTests :: [TestTree] repeatedSingleValueTests = primitiveTests prop_repeated tagsOutOfRangeTests :: [TestTree] tagsOutOfRangeTests = primitiveTests prop_req_out_of_range instance Arbitrary a => Arbitrary (Field n (RequiredField (Always (Value a)))) where arbitrary = putField <$> arbitrary shrink = fmap putField . shrink . getField instance Arbitrary a => Arbitrary (Field n (OptionalField (Last (Value a)))) where arbitrary = putField <$> arbitrary shrink = fmap putField . shrink . getField instance Arbitrary a => Arbitrary (Field n (RepeatedField [Value a])) where arbitrary = putField <$> listOf1 arbitrary shrink = fmap putField . shrink . getField instance Arbitrary a => Arbitrary (PackedList a) where arbitrary = PackedList <$> listOf1 arbitrary shrink = fmap PackedList . shrink . unPackedList instance Arbitrary a => Arbitrary (Signed a) where arbitrary = Signed <$> arbitrary shrink (Signed x) = fmap Signed $ shrink x instance Arbitrary a => Arbitrary (Value a) where arbitrary = Value <$> arbitrary shrink (Value x) = fmap Value $ shrink x instance (Bounded a, Enum a) => Arbitrary (Enumeration a) where arbitrary = Enumeration <$> elements [minBound..maxBound] shrink (Enumeration x) = Enumeration . toEnum <$> shrink (fromEnum x) instance Arbitrary a => Arbitrary (Pb.Fixed a) where arbitrary = Pb.Fixed <$> arbitrary shrink (Pb.Fixed x) = fmap Pb.Fixed $ shrink x instance Arbitrary a => Arbitrary (Always a) where arbitrary = Always <$> arbitrary shrink (Always x) = Always <$> shrink x instance Arbitrary WireField where arbitrary = do tag <- choose (0, 536870912) oneof [ VarintField tag <$> arbitrary , Fixed64Field tag <$> arbitrary , DelimitedField tag . B.pack <$> arbitrary , Fixed32Field tag <$> arbitrary ] shrink (VarintField t v) = VarintField <$> shrink t <*> shrink v shrink (Fixed64Field t v) = Fixed64Field <$> shrink t <*> shrink v shrink (DelimitedField t v) = DelimitedField <$> shrink t <*> fmap B.pack (shrink (B.unpack v)) shrink (Fixed32Field t v) = Fixed32Field <$> shrink t <*> shrink v newtype RequiredValue n a = RequiredValue (Required n (Value a)) deriving (Eq, Generic) instance (EncodeWire a, KnownNat n) => Encode (RequiredValue n a) instance (DecodeWire a, KnownNat n) => Decode (RequiredValue n a) newtype OptionalValue n a = OptionalValue (Optional n (Value a)) deriving (Eq, Generic) instance (EncodeWire a, KnownNat n) => Encode (OptionalValue n a) instance (DecodeWire a, KnownNat n) => Decode (OptionalValue n a) newtype RepeatedValue n a = RepeatedValue (Repeated n (Value a)) deriving (Eq, Generic) instance (EncodeWire a, KnownNat n) => Encode (RepeatedValue n a) instance (DecodeWire a, KnownNat n) => Decode (RepeatedValue n a) arbitraryField :: forall r . Int -> (forall a . (Monoid a, GEncode (K1 R a), GDecode (K1 R a), Eq a, Show a) => a -> Gen r) -> Gen r arbitraryField i f = case someNatVal (fromIntegral i) of Nothing -> fail $ "someNatVal failed for " ++ show i Just (SomeNat (n :: Proxy n)) -> do flavor <- choose (1, 3) case flavor :: Int of 0 -> do -- Packed which <- choose (0, 5) case which :: Int of 0 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Float)) 1 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Double)) 2 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Int32)) 3 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Int64)) 4 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Word32)) 5 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Word64)) -- 6 -> arbitraryMessage (\ (msg :: msg) -> oneof [return (Just msg), return Nothing] >>= \ msg' -> f (putField msg' :: Optional n (Message msg))) -- 7 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Text)) -- 8 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value B.ByteString)) 1 -> do -- Repeated which <- choose (0, 5) case which :: Int of 0 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Float)) 1 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Double)) 2 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Int32)) 3 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Int64)) 4 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Word32)) 5 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Word64)) -- 6 -> arbitraryMessage (\ (msg :: msg) -> oneof [return (Just msg), return Nothing] >>= \ msg' -> f (putField msg' :: Optional n (Message msg))) -- 7 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Text)) -- 8 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value B.ByteString)) 2 -> do -- Optional which <- choose (0, 6) case which :: Int of 0 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Float)) 1 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Double)) 2 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Int32)) 3 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Int64)) 4 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Word32)) 5 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Word64)) 6 -> arbitraryMessage (\ (msg :: msg) -> oneof [return (Just msg), return Nothing] >>= \ msg' -> f (putField msg' :: Optional n (Message msg))) -- 7 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Text)) -- 8 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value B.ByteString)) 3 -> do -- Required which <- choose (0, 6) case which :: Int of 0 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Float)) 1 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Double)) 2 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Int32)) 3 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Int64)) 4 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Word32)) 5 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Word64)) 6 -> arbitraryMessage (\ (msg :: msg) -> f (putField msg :: Required n (Message msg))) -- 7 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Text)) -- 8 -> arbitrary >>= \ x -> f (putField x :: Required n (Value B.ByteString)) data T1 a = T1 a deriving (Show, Eq,Generic) instance GEncode (K1 R a) => Encode (T1 a) instance GDecode (K1 R a) => Decode (T1 a) data T2 a b = T2 a b deriving (Show, Eq,Generic) instance (GEncode (K1 R a), GEncode (K1 R b)) => Encode (T2 a b) instance (GDecode (K1 R a), GDecode (K1 R b)) => Decode (T2 a b) data T3 a b c = T3 a b c deriving (Show, Eq,Generic) instance (GEncode (K1 R a), GEncode (K1 R b), GEncode (K1 R c)) => Encode (T3 a b c) instance (GDecode (K1 R a), GDecode (K1 R b), GDecode (K1 R c)) => Decode (T3 a b c) arbitraryMessage :: forall r . (forall a . (Encode a, Decode a, Generic a, GMessageMonoid (Rep a), Eq a, Show a) => a -> Gen r) -> Gen r arbitraryMessage f = do fieldCount <- choose (1, 3) xs <- fieldTags fieldCount case fieldCount of 1 -> arbitraryField (xs !! 0) (\ f1 -> f (T1 f1)) 2 -> arbitraryField (xs !! 0) (\ f1 -> arbitraryField (xs !! 1) (\ f2 -> f (T2 f1 f2))) 3 -> arbitraryField (xs !! 0) (\ f1 -> arbitraryField (xs !! 1) (\ f2 -> arbitraryField (xs !! 2) (\ f3 -> f (T3 f1 f2 f3)))) fieldTags :: Int -> Gen [Int] fieldTags i = go IntSet.empty [] where go xs ys | IntSet.size xs >= i = return ys | otherwise = do next <- choose (0, 536870912) if next `IntSet.member` xs then go xs ys else go (IntSet.insert next xs) (next:ys) prop_message :: Gen Property prop_message = arbitraryMessage prop_roundtrip_msg prop_wire :: forall a . (Eq a, Arbitrary a, EncodeWire a, DecodeWire a, Typeable a) => Proxy a -> Property prop_wire _ = label ("prop_wire :: " ++ show (typeOf (undefined :: a))) $ do tag <- choose (0, 536870912) val <- arbitrary let bs = runPut (encodeWire tag (val :: a)) dec = do field <- getWireField guard $ tag == wireFieldTag field decodeWire field case runGet dec bs of Right val' -> return $ val == val' Left err -> fail err prop_generic :: Gen Property prop_generic = do msg <- HashMap.fromListWith (++) . fmap (\ c -> (wireFieldTag c, [c])) <$> listOf1 arbitrary prop_roundtrip_msg msg prop_generic_length_prefixed :: Gen Property prop_generic_length_prefixed = do msg <- HashMap.fromListWith (++) . fmap (\ c -> (wireFieldTag c, [c])) <$> listOf1 arbitrary let bs = runPut $ encodeLengthPrefixedMessage (msg :: HashMap Tag [WireField]) case runGet decodeLengthPrefixedMessage bs of Right msg' -> return $ counterexample "foo" $ msg == msg' Left err -> fail err prop_roundtrip_msg :: (Eq a, Encode a, Decode a) => a -> Gen Property prop_roundtrip_msg msg = do let bs = runPut $ encodeMessage msg case runGet decodeMessage bs of Right msg' -> return . property $ msg == msg' Left err -> fail err prop_varint_prefixed_bytestring :: Gen Property prop_varint_prefixed_bytestring = do bs <- B.pack <$> arbitrary prop_roundtrip_value getVarintPrefixedBS putVarintPrefixedBS bs prop_roundtrip_value :: (Eq a, Show a) => Get a -> Putter a -> a -> Gen Property prop_roundtrip_value get put val = do let bs = runPut (put val) case runGet get bs of Right val' -> return $ val === val' Left err -> fail err prop_encode_fail :: Encode a => a -> Gen Prop prop_encode_fail msg = unProperty $ ioProperty $ do res <- try . evaluate . runPut $ encodeMessage msg return $ case res :: Either SomeException B.ByteString of Left _ -> True Right _ -> False prop_req_reify_out_of_range :: forall a r . a -> (forall n . KnownNat n => RequiredValue n a -> Gen r) -> Gen r prop_req_reify_out_of_range a f = do let g :: forall n . KnownNat n => Proxy n -> Gen r g _ = f (RequiredValue (putField a) :: RequiredValue n a) -- according to https://developers.google.com/protocol-buffers/docs/proto -- the max is 2^^29 - 1, or 536,870,911. -- -- the min is set to 0 since reifyIntegral only supports naturals, which -- is also recommended since these are encoded as varints which have -- fairly high overhead for negative tags n <- choose (536870912, toInteger $ (maxBound :: Int)) case someNatVal n of Just (SomeNat x) -> g x prop_reify_valid_tag :: forall r . (forall n . KnownNat n => Proxy n -> Gen r) -> Gen r prop_reify_valid_tag f = do -- according to https://developers.google.com/protocol-buffers/docs/proto -- the max is 2^^29 - 1, or 536,870,911. -- -- the min is set to 0 since reifyIntegral only supports naturals, which -- is also recommended since these are encoded as varints which have -- fairly high overhead for negative tags n <- choose (0, 536870911) case someNatVal n of Just (SomeNat x) -> f x prop_req_reify :: forall a r . a -> (forall n . KnownNat n => RequiredValue n a -> Gen r) -> Gen r prop_req_reify a f = prop_reify_valid_tag g where g :: forall n . KnownNat n => Proxy n -> Gen r g _ = f (RequiredValue (putField a) :: RequiredValue n a) prop_req_out_of_range :: forall a . (Arbitrary (Value a), EncodeWire a) => Proxy a -> Property prop_req_out_of_range _ = MkProperty $ do val <- Just <$> arbitrary prop_req_reify_out_of_range (val :: Maybe (Value a)) prop_encode_fail prop_req :: forall a . (Arbitrary (Value a), Eq a, EncodeWire a, DecodeWire a, Typeable a) => Proxy a -> Property prop_req _ = label ("prop_req :: " ++ show (typeOf (undefined :: a))) $ do val <- Just <$> arbitrary prop_req_reify (val :: Maybe (Value a)) prop_roundtrip_msg prop_repeated_reify :: forall a r . [a] -> (forall n . KnownNat n => RepeatedValue n a -> Gen r) -> Gen r prop_repeated_reify a f = prop_reify_valid_tag g where g :: forall n . KnownNat n => Proxy n -> Gen r g _ = f (RepeatedValue (putField a) :: RepeatedValue n a) prop_repeated :: forall a . (Arbitrary a, Eq a, EncodeWire a, DecodeWire a, Typeable a) => Proxy a -> Property prop_repeated _ = label ("prop_repeated :: " ++ show (typeOf (undefined :: a))) $ do val <- arbitrary prop_repeated_reify (val :: [a]) prop_roundtrip_msg prop_opt_reify :: forall a r . Maybe a -> (forall n . KnownNat n => OptionalValue n a -> Gen r) -> Gen r prop_opt_reify a f = prop_reify_valid_tag g where g :: forall n . KnownNat n => Proxy n -> Gen r g _ = f (OptionalValue (putField a) :: OptionalValue n a) prop_opt :: forall a . (Arbitrary a, Eq a, EncodeWire a, DecodeWire a, Typeable a) => Proxy a -> Property prop_opt _ = label ("prop_opt :: " ++ show (typeOf (undefined :: a))) $ do val <- arbitrary prop_opt_reify (val :: Maybe a) prop_roundtrip_msg -- implement the examples from https://developers.google.com/protocol-buffers/docs/encoding testSpecific :: (Eq a, Show a, Encode a, Decode a) => a -> B.ByteString -> IO () testSpecific msg ref = do let bs = runPut $ encodeMessage msg assertEqual "Encoded message mismatch" bs ref case runGet decodeMessage bs of Right msg' -> assertEqual "Decoded message mismatch" msg msg' Left err -> assertFailure err data Test1 = Test1{test1_a :: Required 1 (Value Int32)} deriving (Generic) deriving instance Eq Test1 deriving instance Show Test1 instance Encode Test1 instance Decode Test1 test1 :: Assertion test1 = testSpecific msg =<< unhex "089601" where msg = Test1{test1_a = putField 150} data Test2 = Test2{test2_b :: Required 2 (Value Text)} deriving (Generic) deriving instance Eq Test2 deriving instance Show Test2 instance Encode Test2 instance Decode Test2 test2 :: Assertion test2 = testSpecific msg =<< unhex "120774657374696e67" where msg = Test2{test2_b = putField "testing"} data Test3 = Test3{test3_c :: Required 3 (Message Test1)} deriving (Generic, Eq, Show) instance Encode Test3 instance Decode Test3 test3 :: Assertion test3 = testSpecific msg =<< unhex "1a03089601" where msg = Test3{test3_c = putField Test1{test1_a = putField 150}} data Test4 = Test4{test4_d :: Packed 4 (Value Word32)} deriving (Generic, Eq, Show) instance Encode Test4 instance Decode Test4 test4 :: Assertion test4 = testSpecific msg =<< unhex "2206038e029ea705" where msg = Test4{test4_d = putField [3,270,86942]} test4_empty :: Assertion test4_empty = testSpecific msg =<< unhex "" where msg = Test4{test4_d = putField mempty} data Test5Enum = Test5A | Test5B deriving (Eq, Show, Enum) data Test5 = Test5{test5_e :: Optional 5 (Enumeration Test5Enum)} deriving (Generic, Eq, Show) instance Encode Test5 instance Decode Test5 data Test6Enum = Test6A | Test6B deriving (Eq, Show, Enum) data Test6 = Test6{test6_e :: Repeated 6 (Enumeration Test6Enum)} deriving (Generic, Eq, Show) instance Encode Test6 instance Decode Test6 data Test7Enum = Test7A deriving (Eq, Show, Enum) data Test7 = Test7{test7_e :: Repeated 7 (Enumeration Test7Enum)} deriving (Generic, Eq, Show) instance Encode Test7 instance Decode Test7 test5 :: Assertion test5 = testSpecific msg =<< unhex "" where msg = Test5{test5_e = putField Nothing} test6 :: Assertion test6 = testSpecific msg =<< unhex "2800" where msg = Test5{test5_e = putField $ Just Test5A } test7 :: Assertion test7 = testSpecific msg =<< unhex "2801" where msg = Test5{test5_e = putField $ Just Test5B } test8 :: Assertion test8 = testSpecific msg =<< unhex "" where msg = Test6{test6_e = putField $ [] } test9 :: Assertion test9 = testSpecific msg =<< unhex "3000" where msg = Test6{test6_e = putField $ [Test6A] } test10 :: Assertion test10 = testSpecific msg =<< unhex "30003001" where msg = Test6{test6_e = putField $ [Test6A, Test6B]} test11 :: Assertion test11 = testSpecific msg =<< unhex "30003000" where msg = Test6{test6_e = putField $ [Test6A, Test6A]} test12 :: Assertion test12 = testSpecific msg =<< unhex "300030013000" where msg = Test6{test6_e = putField $ [Test6A, Test6B, Test6A]} test13 :: Assertion test13 = testSpecific msg =<< unhex "" where msg = Test7{test7_e = putField $ [] } test14 :: Assertion test14 = testSpecific msg =<< unhex "3800" where msg = Test7{test7_e = putField $ [Test7A] } test15 :: Assertion test15 = testSpecific msg =<< unhex "38003800" where msg = Test7{test7_e = putField $ [Test7A, Test7A] } -- some from http://code.google.com/p/protobuf/source/browse/trunk/src/google/protobuf/wire_format_unittest.cc wireFormatZZ :: Assertion wireFormatZZ = do assert $ 0 == zzEncode32 0 assert $ 1 == zzEncode32 (-1) assert $ 2 == zzEncode32 1 assert $ 3 == zzEncode32 (-2) assert $ 0x7FFFFFFE == zzEncode32 (fromIntegral 0x3FFFFFFF) assert $ 0x7FFFFFFF == zzEncode32 (fromIntegral 0xC0000000) assert $ 0xFFFFFFFE == zzEncode32 (fromIntegral 0x7FFFFFFF) assert $ 0xFFFFFFFF == zzEncode32 (fromIntegral 0x80000000) assert $ 0 == zzDecode32 0 assert $ (-1) == zzDecode32 1 assert $ 1 == zzDecode32 2 assert $ (-2) == zzDecode32 3 assert $ fromIntegral 0x3FFFFFFF == zzDecode32 0x7FFFFFFE assert $ fromIntegral 0xC0000000 == zzDecode32 0x7FFFFFFF assert $ fromIntegral 0x7FFFFFFF == zzDecode32 0xFFFFFFFE assert $ fromIntegral 0x80000000 == zzDecode32 0xFFFFFFFF assert $ 0 == zzEncode64 0 assert $ 1 == zzEncode64 (-1) assert $ 2 == zzEncode64 1 assert $ 3 == zzEncode64 (-2) assert $ 0x000000007FFFFFFE == zzEncode64 (fromIntegral 0x000000003FFFFFFF) assert $ 0x000000007FFFFFFF == zzEncode64 (fromIntegral 0xFFFFFFFFC0000000) assert $ 0x00000000FFFFFFFE == zzEncode64 (fromIntegral 0x000000007FFFFFFF) assert $ 0x00000000FFFFFFFF == zzEncode64 (fromIntegral 0xFFFFFFFF80000000) assert $ 0xFFFFFFFFFFFFFFFE == zzEncode64 (fromIntegral 0x7FFFFFFFFFFFFFFF) assert $ 0xFFFFFFFFFFFFFFFF == zzEncode64 (fromIntegral 0x8000000000000000) assert $ 0 == zzDecode64 0 assert $ (-1) == zzDecode64 1 assert $ 1 == zzDecode64 2 assert $ (-2) == zzDecode64 3 assert $ fromIntegral 0x000000003FFFFFFF == zzDecode64 0x000000007FFFFFFE assert $ fromIntegral 0xFFFFFFFFC0000000 == zzDecode64 0x000000007FFFFFFF assert $ fromIntegral 0x000000007FFFFFFF == zzDecode64 0x00000000FFFFFFFE assert $ fromIntegral 0xFFFFFFFF80000000 == zzDecode64 0x00000000FFFFFFFF assert $ fromIntegral 0x7FFFFFFFFFFFFFFF == zzDecode64 0xFFFFFFFFFFFFFFFE assert $ fromIntegral 0x8000000000000000 == zzDecode64 0xFFFFFFFFFFFFFFFF -- these tests are already covered by QuickCheck properties: -- Some easier-to-verify round-trip tests. The inputs (other than 0, 1, -1) -- were chosen semi-randomly via keyboard bashing. let rt32 = zzDecode32 . zzEncode32 rt64 = zzDecode64 . zzEncode64 assert $ 0 == rt32 0 assert $ 1 == rt32 1 assert $ ( -1) == rt32 ( -1) assert $ 14927 == rt32 14927 assert $ (-3612) == rt32 (-3612) assert $ 0 == rt64 0 assert $ 1 == rt64 1 assert $ ( -1) == rt64 ( -1) assert $ 14927 == rt64 14927 assert $ (-3612) == rt64 (-3612) assert $ 856912304801416 == rt64 856912304801416 assert $ (-75123905439571256) == rt64 (-75123905439571256) protobuf-0.2.1.3/tests/Main.hs0000755000000000000000000006070107346545000014275 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} import Test.QuickCheck import Test.QuickCheck.Property hiding (testCase) import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import GHC.Generics import GHC.TypeLits import Control.Applicative import Control.Exception (SomeException, evaluate, try) import Control.Monad import qualified Data.ByteString as B import Data.ByteString.Char8 () import Data.ProtocolBuffers as Pb import Data.ProtocolBuffers.Internal as Pb import Data.ProtocolBuffers.Orphans () import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Hex import Data.Int import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import Data.Monoid import Data.Serialize (Get, Putter, runGet, runPut) import Data.Proxy import Data.Text (Text) import Data.Typeable import Data.Word main :: IO () main = defaultMain tests data EnumFoo = EnumFoo1 | EnumFoo2 | EnumFoo3 deriving (Bounded, Enum, Eq, Typeable) tests :: TestTree tests = testGroup "Root" [ testGroup "Primitive Wire" primitiveWireTests , testGroup "Packed Wire" packedWireTests , testGroup "Required Single Values" requiredSingleValueTests , testGroup "Optional Single Values" optionalSingleValueTests , testGroup "Repeated Single Values" repeatedSingleValueTests -- TODO Fix and re-enable --, testGroup "Tags Out of Range" tagsOutOfRangeTests , testProperty "Generic message coding" prop_generic , testProperty "Generic length prefixed message coding" prop_generic_length_prefixed , testProperty "Varint prefixed bytestring" prop_varint_prefixed_bytestring , testProperty "Random message" prop_message , testCase "Google Reference Test1" test1 , testCase "Google Reference Test2" test2 , testCase "Google Reference Test3" test3 , testCase "Google Reference Test4" test4 , testCase "Packed empty fields" test4_empty , testCase "Optional Enum Test5: Nothing" test5 , testCase "Optional Enum Test5: Just Test5A" test6 , testCase "Optional Enum Test5: Just Test5B" test7 , testCase "Repeated Enum Test6: []" test8 , testCase "Repeated Enum Test6: [Test6A]" test9 , testCase "Repeated Enum Test6: [Test6A, Test6B]" test10 , testCase "Repeated Enum Test6: [Test6A, Test6A]" test11 , testCase "Repeated Enum Test6: [Test6A, Test6B, Test6A]" test12 , testCase "Repeated Enum Test7: []" test13 , testCase "Repeated Enum Test7: [Test7]" test14 , testCase "Repeated Enum Test7: [Test7, Test7]" test15 , testCase "Google WireFormatTest ZigZag" wireFormatZZ ] primitiveTests :: (forall a . (Eq a, Typeable a, Arbitrary a, EncodeWire a, DecodeWire a) => Proxy a -> Property) -> [TestTree] primitiveTests f = [ testProperty "int32" (f (Proxy :: Proxy Int32)) , testProperty "int64" (f (Proxy :: Proxy Int64)) , testProperty "word32" (f (Proxy :: Proxy Word32)) , testProperty "word64" (f (Proxy :: Proxy Word64)) , testProperty "sint32" (f (Proxy :: Proxy (Signed Int32))) , testProperty "sint64" (f (Proxy :: Proxy (Signed Int64))) , testProperty "fixed32" (f (Proxy :: Proxy (Pb.Fixed Word32))) , testProperty "fixed64" (f (Proxy :: Proxy (Pb.Fixed Word64))) , testProperty "sfixed32" (f (Proxy :: Proxy (Pb.Fixed Int32))) , testProperty "sfixed64" (f (Proxy :: Proxy (Pb.Fixed Int64))) , testProperty "float" (f (Proxy :: Proxy Float)) , testProperty "double" (f (Proxy :: Proxy Double)) , testProperty "bool" (f (Proxy :: Proxy Bool)) , testProperty "enum" (f (Proxy :: Proxy (Always (Enumeration EnumFoo)))) ] primitiveWireTests :: [TestTree] primitiveWireTests = primitiveTests prop_wire packedWireTests :: [TestTree] packedWireTests = [ testProperty "int32" (prop_wire (Proxy :: Proxy (PackedList (Value Int32)))) , testProperty "int64" (prop_wire (Proxy :: Proxy (PackedList (Value Int64)))) , testProperty "word32" (prop_wire (Proxy :: Proxy (PackedList (Value Word32)))) , testProperty "word64" (prop_wire (Proxy :: Proxy (PackedList (Value Word64)))) , testProperty "sint32" (prop_wire (Proxy :: Proxy (PackedList (Value (Signed Int32))))) , testProperty "sint64" (prop_wire (Proxy :: Proxy (PackedList (Value (Signed Int64))))) , testProperty "fixed32" (prop_wire (Proxy :: Proxy (PackedList (Value (Pb.Fixed Word32))))) , testProperty "fixed64" (prop_wire (Proxy :: Proxy (PackedList (Value (Pb.Fixed Word64))))) , testProperty "sfixed32" (prop_wire (Proxy :: Proxy (PackedList (Value (Pb.Fixed Int32))))) , testProperty "sfixed64" (prop_wire (Proxy :: Proxy (PackedList (Value (Pb.Fixed Int64))))) , testProperty "float" (prop_wire (Proxy :: Proxy (PackedList (Value Float)))) , testProperty "double" (prop_wire (Proxy :: Proxy (PackedList (Value Double)))) , testProperty "bool" (prop_wire (Proxy :: Proxy (PackedList (Value Bool)))) ] requiredSingleValueTests :: [TestTree] requiredSingleValueTests = primitiveTests prop_req optionalSingleValueTests :: [TestTree] optionalSingleValueTests = primitiveTests prop_opt repeatedSingleValueTests :: [TestTree] repeatedSingleValueTests = primitiveTests prop_repeated tagsOutOfRangeTests :: [TestTree] tagsOutOfRangeTests = primitiveTests prop_req_out_of_range instance Arbitrary a => Arbitrary (Field n (RequiredField (Always (Value a)))) where arbitrary = putField <$> arbitrary shrink = fmap putField . shrink . getField instance Arbitrary a => Arbitrary (Field n (OptionalField (Last (Value a)))) where arbitrary = putField <$> arbitrary shrink = fmap putField . shrink . getField instance Arbitrary a => Arbitrary (Field n (RepeatedField [Value a])) where arbitrary = putField <$> listOf1 arbitrary shrink = fmap putField . shrink . getField instance Arbitrary a => Arbitrary (PackedList a) where arbitrary = PackedList <$> listOf1 arbitrary shrink = fmap PackedList . shrink . unPackedList instance Arbitrary a => Arbitrary (Signed a) where arbitrary = Signed <$> arbitrary shrink (Signed x) = fmap Signed $ shrink x instance Arbitrary a => Arbitrary (Value a) where arbitrary = Value <$> arbitrary shrink (Value x) = fmap Value $ shrink x instance (Bounded a, Enum a) => Arbitrary (Enumeration a) where arbitrary = Enumeration <$> elements [minBound..maxBound] shrink (Enumeration x) = Enumeration . toEnum <$> shrink (fromEnum x) instance Arbitrary a => Arbitrary (Pb.Fixed a) where arbitrary = Pb.Fixed <$> arbitrary shrink (Pb.Fixed x) = fmap Pb.Fixed $ shrink x instance Arbitrary a => Arbitrary (Always a) where arbitrary = Always <$> arbitrary shrink (Always x) = Always <$> shrink x instance Arbitrary WireField where arbitrary = do tag <- choose (0, 536870912) oneof [ VarintField tag <$> arbitrary , Fixed64Field tag <$> arbitrary , DelimitedField tag . B.pack <$> arbitrary , Fixed32Field tag <$> arbitrary ] shrink (VarintField t v) = VarintField <$> shrink t <*> shrink v shrink (Fixed64Field t v) = Fixed64Field <$> shrink t <*> shrink v shrink (DelimitedField t v) = DelimitedField <$> shrink t <*> fmap B.pack (shrink (B.unpack v)) shrink (Fixed32Field t v) = Fixed32Field <$> shrink t <*> shrink v newtype RequiredValue n a = RequiredValue (Required n (Value a)) deriving (Eq, Generic) instance (EncodeWire a, KnownNat n) => Encode (RequiredValue n a) instance (DecodeWire a, KnownNat n) => Decode (RequiredValue n a) newtype OptionalValue n a = OptionalValue (Optional n (Value a)) deriving (Eq, Generic) instance (EncodeWire a, KnownNat n) => Encode (OptionalValue n a) instance (DecodeWire a, KnownNat n) => Decode (OptionalValue n a) newtype RepeatedValue n a = RepeatedValue (Repeated n (Value a)) deriving (Eq, Generic) instance (EncodeWire a, KnownNat n) => Encode (RepeatedValue n a) instance (DecodeWire a, KnownNat n) => Decode (RepeatedValue n a) arbitraryField :: forall r . Int -> (forall a . (Monoid a, GEncode (K1 R a), GDecode (K1 R a), Eq a, Show a) => a -> Gen r) -> Gen r arbitraryField i f = case someNatVal (fromIntegral i) of Nothing -> fail $ "someNatVal failed for " ++ show i Just (SomeNat (n :: Proxy n)) -> do flavor <- choose (1, 3) case flavor :: Int of 0 -> do -- Packed which <- choose (0, 5) case which :: Int of 0 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Float)) 1 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Double)) 2 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Int32)) 3 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Int64)) 4 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Word32)) 5 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Word64)) -- 6 -> arbitraryMessage (\ (msg :: msg) -> oneof [return (Just msg), return Nothing] >>= \ msg' -> f (putField msg' :: Optional n (Message msg))) -- 7 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value Text)) -- 8 -> arbitrary >>= \ x -> f (putField x :: Packed n (Value B.ByteString)) 1 -> do -- Repeated which <- choose (0, 5) case which :: Int of 0 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Float)) 1 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Double)) 2 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Int32)) 3 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Int64)) 4 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Word32)) 5 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Word64)) -- 6 -> arbitraryMessage (\ (msg :: msg) -> oneof [return (Just msg), return Nothing] >>= \ msg' -> f (putField msg' :: Optional n (Message msg))) -- 7 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value Text)) -- 8 -> arbitrary >>= \ x -> f (putField x :: Repeated n (Value B.ByteString)) 2 -> do -- Optional which <- choose (0, 6) case which :: Int of 0 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Float)) 1 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Double)) 2 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Int32)) 3 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Int64)) 4 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Word32)) 5 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Word64)) 6 -> arbitraryMessage (\ (msg :: msg) -> oneof [return (Just msg), return Nothing] >>= \ msg' -> f (putField msg' :: Optional n (Message msg))) -- 7 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value Text)) -- 8 -> arbitrary >>= \ x -> f (putField x :: Optional n (Value B.ByteString)) 3 -> do -- Required which <- choose (0, 6) case which :: Int of 0 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Float)) 1 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Double)) 2 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Int32)) 3 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Int64)) 4 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Word32)) 5 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Word64)) 6 -> arbitraryMessage (\ (msg :: msg) -> f (putField msg :: Required n (Message msg))) -- 7 -> arbitrary >>= \ x -> f (putField x :: Required n (Value Text)) -- 8 -> arbitrary >>= \ x -> f (putField x :: Required n (Value B.ByteString)) data T1 a = T1 a deriving (Show, Eq,Generic) instance GEncode (K1 R a) => Encode (T1 a) instance GDecode (K1 R a) => Decode (T1 a) data T2 a b = T2 a b deriving (Show, Eq,Generic) instance (GEncode (K1 R a), GEncode (K1 R b)) => Encode (T2 a b) instance (GDecode (K1 R a), GDecode (K1 R b)) => Decode (T2 a b) data T3 a b c = T3 a b c deriving (Show, Eq,Generic) instance (GEncode (K1 R a), GEncode (K1 R b), GEncode (K1 R c)) => Encode (T3 a b c) instance (GDecode (K1 R a), GDecode (K1 R b), GDecode (K1 R c)) => Decode (T3 a b c) arbitraryMessage :: forall r . (forall a . (Encode a, Decode a, Generic a, GMessageMonoid (Rep a), Eq a, Show a) => a -> Gen r) -> Gen r arbitraryMessage f = do fieldCount <- choose (1, 3) xs <- fieldTags fieldCount case fieldCount of 1 -> arbitraryField (xs !! 0) (\ f1 -> f (T1 f1)) 2 -> arbitraryField (xs !! 0) (\ f1 -> arbitraryField (xs !! 1) (\ f2 -> f (T2 f1 f2))) 3 -> arbitraryField (xs !! 0) (\ f1 -> arbitraryField (xs !! 1) (\ f2 -> arbitraryField (xs !! 2) (\ f3 -> f (T3 f1 f2 f3)))) fieldTags :: Int -> Gen [Int] fieldTags i = go IntSet.empty [] where go xs ys | IntSet.size xs >= i = return ys | otherwise = do next <- choose (0, 536870912) if next `IntSet.member` xs then go xs ys else go (IntSet.insert next xs) (next:ys) prop_message :: Gen Property prop_message = arbitraryMessage prop_roundtrip_msg prop_wire :: forall a . (Eq a, Arbitrary a, EncodeWire a, DecodeWire a, Typeable a) => Proxy a -> Property prop_wire _ = label ("prop_wire :: " ++ show (typeOf (undefined :: a))) $ do tag <- choose (0, 536870912) val <- arbitrary let bs = runPut (encodeWire tag (val :: a)) dec = do field <- getWireField guard $ tag == wireFieldTag field decodeWire field case runGet dec bs of Right val' -> return $ val == val' Left err -> fail err prop_generic :: Gen Property prop_generic = do msg <- HashMap.fromListWith (++) . fmap (\ c -> (wireFieldTag c, [c])) <$> listOf1 arbitrary prop_roundtrip_msg msg prop_generic_length_prefixed :: Gen Property prop_generic_length_prefixed = do msg <- HashMap.fromListWith (++) . fmap (\ c -> (wireFieldTag c, [c])) <$> listOf1 arbitrary let bs = runPut $ encodeLengthPrefixedMessage (msg :: HashMap Tag [WireField]) case runGet decodeLengthPrefixedMessage bs of Right msg' -> return $ counterexample "foo" $ msg == msg' Left err -> fail err prop_roundtrip_msg :: (Eq a, Encode a, Decode a) => a -> Gen Property prop_roundtrip_msg msg = do let bs = runPut $ encodeMessage msg case runGet decodeMessage bs of Right msg' -> return . property $ msg == msg' Left err -> fail err prop_varint_prefixed_bytestring :: Gen Property prop_varint_prefixed_bytestring = do bs <- B.pack <$> arbitrary prop_roundtrip_value getVarintPrefixedBS putVarintPrefixedBS bs prop_roundtrip_value :: (Eq a, Show a) => Get a -> Putter a -> a -> Gen Property prop_roundtrip_value get put val = do let bs = runPut (put val) case runGet get bs of Right val' -> return $ val === val' Left err -> fail err prop_encode_fail :: Encode a => a -> Gen Prop prop_encode_fail msg = unProperty $ ioProperty $ do res <- try . evaluate . runPut $ encodeMessage msg return $ case res :: Either SomeException B.ByteString of Left _ -> True Right _ -> False prop_req_reify_out_of_range :: forall a r . a -> (forall n . KnownNat n => RequiredValue n a -> Gen r) -> Gen r prop_req_reify_out_of_range a f = do let g :: forall n . KnownNat n => Proxy n -> Gen r g _ = f (RequiredValue (putField a) :: RequiredValue n a) -- according to https://developers.google.com/protocol-buffers/docs/proto -- the max is 2^^29 - 1, or 536,870,911. -- -- the min is set to 0 since reifyIntegral only supports naturals, which -- is also recommended since these are encoded as varints which have -- fairly high overhead for negative tags n <- choose (536870912, toInteger $ (maxBound :: Int)) case someNatVal n of Just (SomeNat x) -> g x prop_reify_valid_tag :: forall r . (forall n . KnownNat n => Proxy n -> Gen r) -> Gen r prop_reify_valid_tag f = do -- according to https://developers.google.com/protocol-buffers/docs/proto -- the max is 2^^29 - 1, or 536,870,911. -- -- the min is set to 0 since reifyIntegral only supports naturals, which -- is also recommended since these are encoded as varints which have -- fairly high overhead for negative tags n <- choose (0, 536870911) case someNatVal n of Just (SomeNat x) -> f x prop_req_reify :: forall a r . a -> (forall n . KnownNat n => RequiredValue n a -> Gen r) -> Gen r prop_req_reify a f = prop_reify_valid_tag g where g :: forall n . KnownNat n => Proxy n -> Gen r g _ = f (RequiredValue (putField a) :: RequiredValue n a) prop_req_out_of_range :: forall a . (Arbitrary (Value a), EncodeWire a) => Proxy a -> Property prop_req_out_of_range _ = MkProperty $ do val <- Just <$> arbitrary prop_req_reify_out_of_range (val :: Maybe (Value a)) prop_encode_fail prop_req :: forall a . (Arbitrary (Value a), Eq a, EncodeWire a, DecodeWire a, Typeable a) => Proxy a -> Property prop_req _ = label ("prop_req :: " ++ show (typeOf (undefined :: a))) $ do val <- Just <$> arbitrary prop_req_reify (val :: Maybe (Value a)) prop_roundtrip_msg prop_repeated_reify :: forall a r . [a] -> (forall n . KnownNat n => RepeatedValue n a -> Gen r) -> Gen r prop_repeated_reify a f = prop_reify_valid_tag g where g :: forall n . KnownNat n => Proxy n -> Gen r g _ = f (RepeatedValue (putField a) :: RepeatedValue n a) prop_repeated :: forall a . (Arbitrary a, Eq a, EncodeWire a, DecodeWire a, Typeable a) => Proxy a -> Property prop_repeated _ = label ("prop_repeated :: " ++ show (typeOf (undefined :: a))) $ do val <- arbitrary prop_repeated_reify (val :: [a]) prop_roundtrip_msg prop_opt_reify :: forall a r . Maybe a -> (forall n . KnownNat n => OptionalValue n a -> Gen r) -> Gen r prop_opt_reify a f = prop_reify_valid_tag g where g :: forall n . KnownNat n => Proxy n -> Gen r g _ = f (OptionalValue (putField a) :: OptionalValue n a) prop_opt :: forall a . (Arbitrary a, Eq a, EncodeWire a, DecodeWire a, Typeable a) => Proxy a -> Property prop_opt _ = label ("prop_opt :: " ++ show (typeOf (undefined :: a))) $ do val <- arbitrary prop_opt_reify (val :: Maybe a) prop_roundtrip_msg -- implement the examples from https://developers.google.com/protocol-buffers/docs/encoding testSpecific :: (Eq a, Show a, Encode a, Decode a) => a -> B.ByteString -> IO () testSpecific msg ref = do let bs = runPut $ encodeMessage msg assertEqual "Encoded message mismatch" bs ref case runGet decodeMessage bs of Right msg' -> assertEqual "Decoded message mismatch" msg msg' Left err -> assertFailure err data Test1 = Test1{test1_a :: Required 1 (Value Int32)} deriving (Generic) deriving instance Eq Test1 deriving instance Show Test1 instance Encode Test1 instance Decode Test1 test1 :: Assertion test1 = testSpecific msg =<< unhex "089601" where msg = Test1{test1_a = putField 150} data Test2 = Test2{test2_b :: Required 2 (Value Text)} deriving (Generic) deriving instance Eq Test2 deriving instance Show Test2 instance Encode Test2 instance Decode Test2 test2 :: Assertion test2 = testSpecific msg =<< unhex "120774657374696e67" where msg = Test2{test2_b = putField "testing"} data Test3 = Test3{test3_c :: Required 3 (Message Test1)} deriving (Generic, Eq, Show) instance Encode Test3 instance Decode Test3 test3 :: Assertion test3 = testSpecific msg =<< unhex "1a03089601" where msg = Test3{test3_c = putField Test1{test1_a = putField 150}} data Test4 = Test4{test4_d :: Packed 4 (Value Word32)} deriving (Generic, Eq, Show) instance Encode Test4 instance Decode Test4 test4 :: Assertion test4 = testSpecific msg =<< unhex "2206038e029ea705" where msg = Test4{test4_d = putField [3,270,86942]} test4_empty :: Assertion test4_empty = testSpecific msg =<< unhex "" where msg = Test4{test4_d = putField mempty} data Test5Enum = Test5A | Test5B deriving (Eq, Show, Enum) data Test5 = Test5{test5_e :: Optional 5 (Enumeration Test5Enum)} deriving (Generic, Eq, Show) instance Encode Test5 instance Decode Test5 data Test6Enum = Test6A | Test6B deriving (Eq, Show, Enum) data Test6 = Test6{test6_e :: Repeated 6 (Enumeration Test6Enum)} deriving (Generic, Eq, Show) instance Encode Test6 instance Decode Test6 data Test7Enum = Test7A deriving (Eq, Show, Enum) data Test7 = Test7{test7_e :: Repeated 7 (Enumeration Test7Enum)} deriving (Generic, Eq, Show) instance Encode Test7 instance Decode Test7 test5 :: Assertion test5 = testSpecific msg =<< unhex "" where msg = Test5{test5_e = putField Nothing} test6 :: Assertion test6 = testSpecific msg =<< unhex "2800" where msg = Test5{test5_e = putField $ Just Test5A } test7 :: Assertion test7 = testSpecific msg =<< unhex "2801" where msg = Test5{test5_e = putField $ Just Test5B } test8 :: Assertion test8 = testSpecific msg =<< unhex "" where msg = Test6{test6_e = putField $ [] } test9 :: Assertion test9 = testSpecific msg =<< unhex "3000" where msg = Test6{test6_e = putField $ [Test6A] } test10 :: Assertion test10 = testSpecific msg =<< unhex "30003001" where msg = Test6{test6_e = putField $ [Test6A, Test6B]} test11 :: Assertion test11 = testSpecific msg =<< unhex "30003000" where msg = Test6{test6_e = putField $ [Test6A, Test6A]} test12 :: Assertion test12 = testSpecific msg =<< unhex "300030013000" where msg = Test6{test6_e = putField $ [Test6A, Test6B, Test6A]} test13 :: Assertion test13 = testSpecific msg =<< unhex "" where msg = Test7{test7_e = putField $ [] } test14 :: Assertion test14 = testSpecific msg =<< unhex "3800" where msg = Test7{test7_e = putField $ [Test7A] } test15 :: Assertion test15 = testSpecific msg =<< unhex "38003800" where msg = Test7{test7_e = putField $ [Test7A, Test7A] } -- some from http://code.google.com/p/protobuf/source/browse/trunk/src/google/protobuf/wire_format_unittest.cc wireFormatZZ :: Assertion wireFormatZZ = do assert $ 0 == zzEncode32 0 assert $ 1 == zzEncode32 (-1) assert $ 2 == zzEncode32 1 assert $ 3 == zzEncode32 (-2) assert $ 0x7FFFFFFE == zzEncode32 (fromIntegral 0x3FFFFFFF) assert $ 0x7FFFFFFF == zzEncode32 (fromIntegral 0xC0000000) assert $ 0xFFFFFFFE == zzEncode32 (fromIntegral 0x7FFFFFFF) assert $ 0xFFFFFFFF == zzEncode32 (fromIntegral 0x80000000) assert $ 0 == zzDecode32 0 assert $ (-1) == zzDecode32 1 assert $ 1 == zzDecode32 2 assert $ (-2) == zzDecode32 3 assert $ fromIntegral 0x3FFFFFFF == zzDecode32 0x7FFFFFFE assert $ fromIntegral 0xC0000000 == zzDecode32 0x7FFFFFFF assert $ fromIntegral 0x7FFFFFFF == zzDecode32 0xFFFFFFFE assert $ fromIntegral 0x80000000 == zzDecode32 0xFFFFFFFF assert $ 0 == zzEncode64 0 assert $ 1 == zzEncode64 (-1) assert $ 2 == zzEncode64 1 assert $ 3 == zzEncode64 (-2) assert $ 0x000000007FFFFFFE == zzEncode64 (fromIntegral 0x000000003FFFFFFF) assert $ 0x000000007FFFFFFF == zzEncode64 (fromIntegral 0xFFFFFFFFC0000000) assert $ 0x00000000FFFFFFFE == zzEncode64 (fromIntegral 0x000000007FFFFFFF) assert $ 0x00000000FFFFFFFF == zzEncode64 (fromIntegral 0xFFFFFFFF80000000) assert $ 0xFFFFFFFFFFFFFFFE == zzEncode64 (fromIntegral 0x7FFFFFFFFFFFFFFF) assert $ 0xFFFFFFFFFFFFFFFF == zzEncode64 (fromIntegral 0x8000000000000000) assert $ 0 == zzDecode64 0 assert $ (-1) == zzDecode64 1 assert $ 1 == zzDecode64 2 assert $ (-2) == zzDecode64 3 assert $ fromIntegral 0x000000003FFFFFFF == zzDecode64 0x000000007FFFFFFE assert $ fromIntegral 0xFFFFFFFFC0000000 == zzDecode64 0x000000007FFFFFFF assert $ fromIntegral 0x000000007FFFFFFF == zzDecode64 0x00000000FFFFFFFE assert $ fromIntegral 0xFFFFFFFF80000000 == zzDecode64 0x00000000FFFFFFFF assert $ fromIntegral 0x7FFFFFFFFFFFFFFF == zzDecode64 0xFFFFFFFFFFFFFFFE assert $ fromIntegral 0x8000000000000000 == zzDecode64 0xFFFFFFFFFFFFFFFF -- these tests are already covered by QuickCheck properties: -- Some easier-to-verify round-trip tests. The inputs (other than 0, 1, -1) -- were chosen semi-randomly via keyboard bashing. let rt32 = zzDecode32 . zzEncode32 rt64 = zzDecode64 . zzEncode64 assert $ 0 == rt32 0 assert $ 1 == rt32 1 assert $ ( -1) == rt32 ( -1) assert $ 14927 == rt32 14927 assert $ (-3612) == rt32 (-3612) assert $ 0 == rt64 0 assert $ 1 == rt64 1 assert $ ( -1) == rt64 ( -1) assert $ 14927 == rt64 14927 assert $ (-3612) == rt64 (-3612) assert $ 856912304801416 == rt64 856912304801416 assert $ (-75123905439571256) == rt64 (-75123905439571256)