diff --git a/plugin/Main.hs b/plugin/Main.hs deleted file mode 100644 --- a/plugin/Main.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Control.Monad.Identity -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as Bl -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Int -import Data.Monoid -import Data.ProtocolBuffers -import Data.ProtocolBuffers.Internal -import Data.Serialize -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL -import qualified Data.Text.Lazy.IO as TextL -import Debug.Trace -import qualified Data.TypeLevel as Tl -import GHC.Generics -import Language.Haskell.Exts -import Language.Haskell.Exts.Pretty (prettyPrint) -import Language.Haskell.Exts.SrcLoc (noLoc) - -data FieldDescriptorProto_Type - = TYPE_DOUBLE - | TYPE_FLOAT - | TYPE_INT64 - | TYPE_UINT64 - | TYPE_INT32 - | TYPE_FIXED64 - | TYPE_FIXED32 - | TYPE_BOOL - | TYPE_STRING - | TYPE_GROUP - | TYPE_MESSAGE - | TYPE_BYTES - | TYPE_UINT32 - | TYPE_ENUM - | TYPE_SFIXED32 - | TYPE_SFIXED64 - | TYPE_SINT32 - | TYPE_SINT64 - deriving (Eq, Show) - -instance Enum FieldDescriptorProto_Type where - toEnum 1 = TYPE_DOUBLE - toEnum 2 = TYPE_FLOAT - toEnum 3 = TYPE_INT64 - toEnum 4 = TYPE_UINT64 - toEnum 5 = TYPE_INT32 - toEnum 6 = TYPE_FIXED64 - toEnum 7 = TYPE_FIXED32 - toEnum 8 = TYPE_BOOL - toEnum 9 = TYPE_STRING - toEnum 10 = TYPE_GROUP - toEnum 11 = TYPE_MESSAGE - toEnum 12 = TYPE_BYTES - toEnum 13 = TYPE_UINT32 - toEnum 14 = TYPE_ENUM - toEnum 15 = TYPE_SFIXED32 - toEnum 16 = TYPE_SFIXED64 - toEnum 17 = TYPE_SINT32 - toEnum 18 = TYPE_SINT64 - fromEnum TYPE_DOUBLE = 1 - fromEnum TYPE_FLOAT = 2 - fromEnum TYPE_INT64 = 3 - fromEnum TYPE_UINT64 = 4 - fromEnum TYPE_INT32 = 5 - fromEnum TYPE_FIXED64 = 6 - fromEnum TYPE_FIXED32 = 7 - fromEnum TYPE_BOOL = 8 - fromEnum TYPE_STRING = 9 - fromEnum TYPE_GROUP = 10 - fromEnum TYPE_MESSAGE = 11 - fromEnum TYPE_BYTES = 12 - fromEnum TYPE_UINT32 = 13 - fromEnum TYPE_ENUM = 14 - fromEnum TYPE_SFIXED32 = 15 - fromEnum TYPE_SFIXED64 = 16 - fromEnum TYPE_SINT32 = 17 - fromEnum TYPE_SINT64 = 18 - -data FieldDescriptorProto_Label - = LABEL_OPTIONAL - | LABEL_REQUIRED - | LABEL_REPEATED - deriving (Eq, Show) - -instance Enum FieldDescriptorProto_Label where - toEnum 1 = LABEL_OPTIONAL - toEnum 2 = LABEL_REQUIRED - toEnum 3 = LABEL_REPEATED - fromEnum LABEL_OPTIONAL = 1 - fromEnum LABEL_REQUIRED = 2 - fromEnum LABEL_REPEATED = 3 - -data FieldOptions = FieldOptions - { fieldOptionsPacked :: Optional Tl.D2 (Value Bool) - , fieldOptionsDeprecated :: Optional Tl.D3 (Value Bool) - , fieldOptionsLazy :: Optional Tl.D5 (Value Bool) -- disable strict field? - -- optional CType ctype = 1 [default = STRING]; - } deriving (Generic, Show) - -instance Decode FieldOptions - -data FieldDescriptorProto = FieldDescriptorProto - { fieldDescriptorName :: Optional Tl.D1 (Value Text) - , fieldDescriptorNumber :: Optional Tl.D3 (Value Int32) - , fieldDescriptorLabel :: Optional Tl.D4 (Enumeration FieldDescriptorProto_Label) - , fieldDescriptorType :: Optional Tl.D5 (Enumeration FieldDescriptorProto_Type) - , fieldDescriptorTypeName :: Optional Tl.D6 (Value Text) - , fieldDescriptorExtendee :: Optional Tl.D2 (Value Text) - , fieldDescriptorDefaultValue :: Optional Tl.D7 (Value Text) - , fieldDescriptorOptions :: Optional Tl.D8 (Message FieldOptions) - } deriving (Generic, Show) - -instance Decode FieldDescriptorProto - -data DescriptorProto = DescriptorProto - { descriptorName :: Optional Tl.D1 (Value Text) - , descriptorField :: Repeated Tl.D2 (Message FieldDescriptorProto) - , descriptorExtension :: Repeated Tl.D6 (Message FieldDescriptorProto) - , descriptorNestedType :: Repeated Tl.D3 (Message DescriptorProto) - -- repeated EnumDescriptorProto enum_type = 4; - - -- message ExtensionRange { - -- optional int32 start = 1; - -- optional int32 end = 2; - -- } - -- repeated ExtensionRange extension_range = 5; - - -- optional MessageOptions options = 7; - } deriving (Generic, Show) - -instance Decode DescriptorProto - -data FileDescriptorProto = FileDescriptorProto - { fileDescriptorName :: Optional Tl.D1 (Value Text) - , fileDescriptorPackage :: Optional Tl.D2 (Value Text) - , fileDescriptorDependency :: Repeated Tl.D3 (Value Text) - , fileDescriptorPublicDependency :: Repeated Tl.D10 (Value Int32) - , fileDescriptorWeakDependency :: Repeated Tl.D11 (Value Int32) - - -- All top-level definitions in this file. - , fileDescriptorMessageType :: Repeated Tl.D4 (Message DescriptorProto) - -- repeated EnumDescriptorProto enum_type = 5; - -- repeated ServiceDescriptorProto service = 6; - , fileDescriptorExtension :: Repeated Tl.D7 (Message FieldDescriptorProto) - - -- optional FileOptions options = 8; - - -- This field contains optional information about the original source code. - -- You may safely remove this entire field whithout harming runtime - -- functionality of the descriptors -- the information is needed only by - -- development tools. - -- optional SourceCodeInfo source_code_info = 9; - } deriving (Generic, Show) - -instance Decode FileDescriptorProto - -data CodeGeneratorRequest = CodeGeneratorRequest - { fileToGenerate :: Repeated Tl.D1 (Value Text) - , parameter :: Optional Tl.D2 (Value Text) - , protoFile :: Repeated Tl.D15 (Message FileDescriptorProto) - } deriving (Generic, Show) - -instance Decode CodeGeneratorRequest - -data CodeGeneratorResponse_File = CodeGeneratorResponse_File - { responseFileName :: Optional Tl.D1 (Value Text) - , responseInsertionPoint :: Optional Tl.D2 (Value Text) - , responseContent :: Optional Tl.D15 (Value Text) - } deriving (Generic, Show) - -instance Encode CodeGeneratorResponse_File - -data CodeGeneratorResponse = CodeGeneratorResponse - { errorStr :: Optional Tl.D1 (Value String) - , responseFiles :: Repeated Tl.D15 (Message CodeGeneratorResponse_File) - } deriving (Generic, Show) - -instance Encode CodeGeneratorResponse - -blah :: FileDescriptorProto -> Text -blah fdp = T.pack $ prettyPrint m where - m = Module noLoc (ModuleName "Foo") pragmas Nothing exports imports decls - pragmas = [LanguagePragma noLoc [Ident "DataKinds"]] - exports = Nothing - imports = [] - decls = [] - -blahs :: [FileDescriptorProto] -> [CodeGeneratorResponse_File] -blahs = fmap step where - step fpd = CodeGeneratorResponse_File - { responseFileName = putField $ Just "test.hs" - , responseInsertionPoint = putField Nothing - , responseContent = putField . Just $ blah fpd - } - --- getCodeFor :: HashMap Tag [Field] -> Bl.ByteString -getCodeFor :: CodeGeneratorRequest -> CodeGeneratorResponse -getCodeFor val = traceShow val CodeGeneratorResponse - { errorStr = putField Nothing -- some failure string" - , responseFiles = putField . blahs . getField $ protoFile val - } - -main :: IO () -main = Bl.interact $ \ input -> - runPutLazy . encodeMessage $ - case runGetLazy decodeMessage input of - Right val -> getCodeFor val - Left err -> CodeGeneratorResponse - { errorStr = putField $ Just err - , responseFiles = putField [] - } diff --git a/protobuf.cabal b/protobuf.cabal --- a/protobuf.cabal +++ b/protobuf.cabal @@ -1,5 +1,5 @@ name: protobuf -version: 0.1.2 +version: 0.1.3 synopsis: Google Protocol Buffers via GHC.Generics description: Google Protocol Buffers via GHC.Generics. @@ -36,6 +36,7 @@ exposed-modules: Data.ProtocolBuffers Data.ProtocolBuffers.Internal + Data.ProtocolBuffers.Orphans other-modules: Data.ProtocolBuffers.Decode Data.ProtocolBuffers.Encode @@ -55,27 +56,6 @@ text >= 0.10, type-level >= 0.2, unordered-containers >= 0.2 - ghc-options: - -Wall - -executable protoc-gen-hs - default-language: - Haskell2010 - hs-source-dirs: - plugin - main-is: - Main.hs - build-depends: - base >= 4.5 && < 5, - bytestring, - cereal, - ghc-prim, - haskell-src-exts, - mtl, - protobuf, - text, - type-level, - unordered-containers ghc-options: -Wall 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 @@ -36,12 +36,12 @@ -- Decode a Protocol Buffers message. decodeMessage :: Decode a => Get a {-# INLINE decodeMessage #-} -decodeMessage = decode =<< go HashMap.empty where +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 (flip (++)) (wireFieldTag v) [v] msg + Just v -> go $! HashMap.insertWith (\(x:[]) xs -> x:xs) (wireFieldTag v) [v] msg Nothing -> return msg -- | diff --git a/src/Data/ProtocolBuffers/Orphans.hs b/src/Data/ProtocolBuffers/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/Data/ProtocolBuffers/Orphans.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- 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 (Foldable) where + +import Data.Foldable (Foldable) +import Data.Monoid (Last(..)) + +deriving instance Foldable Last diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -9,13 +9,13 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit (Assertion, assert, assertEqual, assertFailure) import Test.QuickCheck -import Test.QuickCheck.Modifiers import Test.QuickCheck.Property import GHC.Generics (Generic) @@ -23,7 +23,6 @@ import Control.Applicative import Control.Exception (SomeException, evaluate, try) import Control.Monad -import Control.Monad.Identity import qualified Data.ByteString as B import Data.ByteString.Char8 () import Data.ProtocolBuffers as Pb @@ -32,12 +31,10 @@ import qualified Data.HashMap.Strict as HashMap import Data.Hex import Data.Int -import Data.List import Data.Monoid import Data.Serialize (runGet, runPut) import Data.Proxy import Data.Text (Text) -import qualified Data.Text as T import Data.Typeable import Data.Word import Data.TypeLevel (D1, D2, D3, D4, Nat, reifyIntegral) @@ -51,11 +48,13 @@ | EnumFoo3 deriving (Bounded, Enum, Eq, Typeable) +tests :: [Test] tests = [ testGroup "Primitive Wire" primitiveWireTests , testGroup "Packed Wire" packedWireTests , testGroup "Required Single Values" requiredSingleValueTests , testGroup "Optional Single Values" optionalSingleValueTests + , testGroup "Repeated Single Values" repeatedSingleValueTests , testGroup "Tags Out of Range" tagsOutOfRangeTests , testProperty "Generic message coding" prop_generic , testProperty "Generic length prefixed message coding" prop_generic_length_prefixed @@ -110,6 +109,9 @@ optionalSingleValueTests :: [Test] optionalSingleValueTests = primitiveTests prop_opt +repeatedSingleValueTests :: [Test] +repeatedSingleValueTests = primitiveTests prop_repeated + tagsOutOfRangeTests :: [Test] tagsOutOfRangeTests = primitiveTests prop_req_out_of_range @@ -176,6 +178,12 @@ instance (EncodeWire a, Nat n) => Encode (OptionalValue n a) instance (DecodeWire a, Nat n) => Decode (OptionalValue n a) +newtype RepeatedValue n a = RepeatedValue (Repeated n (Value a)) + deriving (Eq, Generic) + +instance (EncodeWire a, Nat n) => Encode (RepeatedValue n a) +instance (DecodeWire a, Nat n) => Decode (RepeatedValue n a) + 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) @@ -252,6 +260,24 @@ val <- Just <$> arbitrary prop_req_reify (val :: Maybe (Value a)) prop_roundtrip +prop_repeated_reify :: forall a r . [a] -> (forall n . Nat n => RepeatedValue n a -> Gen r) -> Gen r +prop_repeated_reify a f = do + let g :: forall n . Nat n => n -> Gen r + g _ = f (RepeatedValue (putField a) :: RepeatedValue 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 (0, 536870911) + reifyIntegral (n :: Int32) g + +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 + prop_opt_reify :: forall a r . Maybe a -> (forall n . Nat n => OptionalValue n a -> Gen r) -> Gen r prop_opt_reify a f = do let g :: forall n . Nat n => n -> Gen r @@ -271,6 +297,7 @@ prop_opt_reify (val :: Maybe a) prop_roundtrip -- 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