diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,6 @@ +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" diff --git a/protobuf.cabal b/protobuf.cabal --- a/protobuf.cabal +++ b/protobuf.cabal @@ -1,5 +1,5 @@ name: protobuf -version: 0.2.0.3 +version: 0.2.0.4 synopsis: Google Protocol Buffers via GHC.Generics description: Google Protocol Buffers via GHC.Generics. @@ -90,6 +90,7 @@ base >= 4.7 && < 5, bytestring, cereal, + containers, hex, mtl, protobuf, diff --git a/src/Data/ProtocolBuffers/Decode.hs b/src/Data/ProtocolBuffers/Decode.hs --- a/src/Data/ProtocolBuffers/Decode.hs +++ b/src/Data/ProtocolBuffers/Decode.hs @@ -89,7 +89,7 @@ let tag = fromIntegral $ natVal (Proxy :: Proxy n) in case HashMap.lookup tag msg of Just val -> K1 . Field . c <$> foldMapM decodeWire val - Nothing -> pure . K1 . Field $ c mempty + 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) @@ -103,7 +103,7 @@ instance (Enum a, KnownNat n) => GDecode (K1 i (Field n (OptionalField (Last (Enumeration a))))) where gdecode msg = do - K1 mx <- fieldDecode Optional msg + 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 diff --git a/src/Data/ProtocolBuffers/Encode.hs b/src/Data/ProtocolBuffers/Encode.hs --- a/src/Data/ProtocolBuffers/Encode.hs +++ b/src/Data/ProtocolBuffers/Encode.hs @@ -9,6 +9,7 @@ ( Encode(..) , encodeMessage , encodeLengthPrefixedMessage + , GEncode ) where import qualified Data.ByteString as B diff --git a/src/Data/ProtocolBuffers/Internal.hs b/src/Data/ProtocolBuffers/Internal.hs --- a/src/Data/ProtocolBuffers/Internal.hs +++ b/src/Data/ProtocolBuffers/Internal.hs @@ -21,8 +21,13 @@ , 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 diff --git a/src/Data/ProtocolBuffers/Message.hs b/src/Data/ProtocolBuffers/Message.hs --- a/src/Data/ProtocolBuffers/Message.hs +++ b/src/Data/ProtocolBuffers/Message.hs @@ -11,6 +11,7 @@ module Data.ProtocolBuffers.Message ( Message(..) + , GMessageMonoid ) where import Control.Applicative diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -18,7 +18,7 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck -import GHC.Generics (Generic) +import GHC.Generics import GHC.TypeLits import Control.Applicative @@ -33,6 +33,8 @@ 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 @@ -61,6 +63,7 @@ , 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 @@ -190,6 +193,97 @@ 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) @@ -203,12 +297,12 @@ Right val' -> return $ val == val' Left err -> fail err -prop_generic :: (Arbitrary WireField) => Gen Property +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 :: (Arbitrary WireField) => Gen Property +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]) @@ -373,41 +467,41 @@ assert $ 1 == zzEncode32 (-1) assert $ 2 == zzEncode32 1 assert $ 3 == zzEncode32 (-2) - assert $ 0x7FFFFFFE == zzEncode32 0x3FFFFFFF - assert $ 0x7FFFFFFF == zzEncode32 0xC0000000 - assert $ 0xFFFFFFFE == zzEncode32 0x7FFFFFFF - assert $ 0xFFFFFFFF == zzEncode32 0x80000000 + 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 $ 0x3FFFFFFF == zzDecode32 0x7FFFFFFE - assert $ 0xC0000000 == zzDecode32 0x7FFFFFFF - assert $ 0x7FFFFFFF == zzDecode32 0xFFFFFFFE - assert $ 0x80000000 == zzDecode32 0xFFFFFFFF + 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 0x000000003FFFFFFF - assert $ 0x000000007FFFFFFF == zzEncode64 0xFFFFFFFFC0000000 - assert $ 0x00000000FFFFFFFE == zzEncode64 0x000000007FFFFFFF - assert $ 0x00000000FFFFFFFF == zzEncode64 0xFFFFFFFF80000000 - assert $ 0xFFFFFFFFFFFFFFFE == zzEncode64 0x7FFFFFFFFFFFFFFF - assert $ 0xFFFFFFFFFFFFFFFF == zzEncode64 0x8000000000000000 + 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 $ 0x000000003FFFFFFF == zzDecode64 0x000000007FFFFFFE - assert $ 0xFFFFFFFFC0000000 == zzDecode64 0x000000007FFFFFFF - assert $ 0x000000007FFFFFFF == zzDecode64 0x00000000FFFFFFFE - assert $ 0xFFFFFFFF80000000 == zzDecode64 0x00000000FFFFFFFF - assert $ 0x7FFFFFFFFFFFFFFF == zzDecode64 0xFFFFFFFFFFFFFFFE - assert $ 0x8000000000000000 == zzDecode64 0xFFFFFFFFFFFFFFFF + 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)