diff --git a/gen/TestProto.hs b/gen/TestProto.hs --- a/gen/TestProto.hs +++ b/gen/TestProto.hs @@ -4,9 +4,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-missing-export-lists #-} -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! @@ -1133,6 +1134,91 @@ HsJSONPB.insOrdFromList [("repeatedField1", withRepetitionRepeatedField1)]}}) + +data WithRepeatedSigned = WithRepeatedSigned{withRepeatedSignedR32 + :: Hs.Vector Hs.Int32, + withRepeatedSignedR64 :: Hs.Vector Hs.Int64} + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) + +instance HsProtobuf.Named WithRepeatedSigned where + nameOf _ = (Hs.fromString "WithRepeatedSigned") + +instance HsProtobuf.HasDefault WithRepeatedSigned + +instance HsProtobuf.Message WithRepeatedSigned where + encodeMessage _ + WithRepeatedSigned{withRepeatedSignedR32 = withRepeatedSignedR32, + withRepeatedSignedR64 = withRepeatedSignedR64} + = (Hs.mconcat + [(HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 1) + (Hs.coerce @(Hs.Vector Hs.Int32) + @(HsProtobuf.PackedVec (HsProtobuf.Signed Hs.Int32)) + withRepeatedSignedR32)), + (HsProtobuf.encodeMessageField (HsProtobuf.FieldNumber 2) + (Hs.coerce @(Hs.Vector Hs.Int64) + @(HsProtobuf.PackedVec (HsProtobuf.Signed Hs.Int64)) + withRepeatedSignedR64))]) + decodeMessage _ + = (Hs.pure WithRepeatedSigned) <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec (HsProtobuf.Signed Hs.Int32))) + @(_ (Hs.Vector Hs.Int32)) + (HsProtobuf.at HsProtobuf.decodeMessageField + (HsProtobuf.FieldNumber 1))) + <*> + (Hs.coerce @(_ (HsProtobuf.PackedVec (HsProtobuf.Signed Hs.Int64))) + @(_ (Hs.Vector Hs.Int64)) + (HsProtobuf.at HsProtobuf.decodeMessageField + (HsProtobuf.FieldNumber 2))) + dotProto _ + = [(HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 1) + (HsProtobuf.Repeated HsProtobuf.SInt32) + (HsProtobuf.Single "r32") + [] + ""), + (HsProtobuf.DotProtoField (HsProtobuf.FieldNumber 2) + (HsProtobuf.Repeated HsProtobuf.SInt64) + (HsProtobuf.Single "r64") + [] + "")] + +instance HsJSONPB.ToJSONPB WithRepeatedSigned where + toJSONPB (WithRepeatedSigned f1 f2) + = (HsJSONPB.object ["r32" .= f1, "r64" .= f2]) + toEncodingPB (WithRepeatedSigned f1 f2) + = (HsJSONPB.pairs ["r32" .= f1, "r64" .= f2]) + +instance HsJSONPB.FromJSONPB WithRepeatedSigned where + parseJSONPB + = (HsJSONPB.withObject "WithRepeatedSigned" + (\ obj -> + (Hs.pure WithRepeatedSigned) <*> obj .: "r32" <*> obj .: "r64")) + +instance HsJSONPB.ToJSON WithRepeatedSigned where + toJSON = HsJSONPB.toAesonValue + toEncoding = HsJSONPB.toAesonEncoding + +instance HsJSONPB.FromJSON WithRepeatedSigned where + parseJSON = HsJSONPB.parseJSONPB + +instance HsJSONPB.ToSchema WithRepeatedSigned where + declareNamedSchema _ + = do let declare_r32 = HsJSONPB.declareSchemaRef + withRepeatedSignedR32 <- declare_r32 Proxy.Proxy + let declare_r64 = HsJSONPB.declareSchemaRef + withRepeatedSignedR64 <- declare_r64 Proxy.Proxy + let _ = Hs.pure WithRepeatedSigned <*> HsJSONPB.asProxy declare_r32 + <*> HsJSONPB.asProxy declare_r64 + Hs.return + (HsJSONPB.NamedSchema{HsJSONPB._namedSchemaName = + Hs.Just "WithRepeatedSigned", + HsJSONPB._namedSchemaSchema = + Hs.mempty{HsJSONPB._schemaParamSchema = + Hs.mempty{HsJSONPB._paramSchemaType = + Hs.Just HsJSONPB.SwaggerObject}, + HsJSONPB._schemaProperties = + HsJSONPB.insOrdFromList + [("r32", withRepeatedSignedR32), + ("r64", withRepeatedSignedR64)]}}) data WithFixed = WithFixed{withFixedFixed1 :: Hs.Word32, withFixedFixed2 :: Hs.Int32, withFixedFixed3 :: Hs.Word64, diff --git a/gen/TestProtoImport.hs b/gen/TestProtoImport.hs --- a/gen/TestProtoImport.hs +++ b/gen/TestProtoImport.hs @@ -4,9 +4,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-missing-export-lists #-} -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! diff --git a/gen/TestProtoOneof.hs b/gen/TestProtoOneof.hs --- a/gen/TestProtoOneof.hs +++ b/gen/TestProtoOneof.hs @@ -4,9 +4,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-missing-export-lists #-} -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! diff --git a/gen/TestProtoOneofImport.hs b/gen/TestProtoOneofImport.hs --- a/gen/TestProtoOneofImport.hs +++ b/gen/TestProtoOneofImport.hs @@ -4,9 +4,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-missing-export-lists #-} -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! diff --git a/proto3-suite.cabal b/proto3-suite.cabal --- a/proto3-suite.cabal +++ b/proto3-suite.cabal @@ -1,5 +1,5 @@ name: proto3-suite -version: 0.4.1 +version: 0.4.2 synopsis: A low level library for writing out data in the Protocol Buffers wire format license: Apache-2.0 author: Awake Security @@ -44,6 +44,8 @@ Proto3.Suite.Tutorial Proto3.Suite.Types + Google.Protobuf.Timestamp + Proto3.Suite.DotProto.Internal Proto3.Suite.JSONPB.Class @@ -70,11 +72,12 @@ parsers >= 0.12 && <0.13, pretty ==1.1.*, pretty-show >= 1.6.12 && < 2.0, - proto3-wire == 1.2.*, + proto3-wire >= 1.2.2 && < 1.3, QuickCheck >=2.10 && <2.15, quickcheck-instances < 0.4, safe ==0.3.*, system-filepath, + time, text >= 0.2 && <1.3, transformers >=0.4 && <0.6, turtle, diff --git a/src/Google/Protobuf/Timestamp.hs b/src/Google/Protobuf/Timestamp.hs new file mode 100644 --- /dev/null +++ b/src/Google/Protobuf/Timestamp.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-missing-export-lists #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} + +-- | This module has been initialized using +-- https://github.com/protocolbuffers/protobuf/blob/master/src/google/protobuf/timestamp.proto +-- +-- The ToJSONPB and FromJSONPB instances have been modified to +-- be compatible with the json rfc3339 encoding +module Google.Protobuf.Timestamp where + +import Control.Applicative ((<$>), (<*>), (<|>)) +import qualified Control.Applicative as Hs +import qualified Control.DeepSeq as Hs +import qualified Control.Monad as Hs +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encoding as Aeson +import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString as Hs +import qualified Data.Coerce as Hs +import qualified Data.Int as Hs (Int16, Int32, Int64) +import qualified Data.List.NonEmpty as Hs (NonEmpty (..)) +import qualified Data.Map as Hs (Map, mapKeysMonotonic) +import qualified Data.Proxy as Proxy +import qualified Data.String as Hs (fromString) +import qualified Data.Text.Lazy as Hs (Text) +import qualified Data.Text.Lazy as Text +import qualified Data.Time.Clock as Time +import qualified Data.Time.Clock.System as Time +import qualified Data.Time.Format as Time +import qualified Data.Vector as Hs (Vector) +import qualified Data.Word as Hs (Word16, Word32, Word64) +import qualified GHC.Enum as Hs +import qualified GHC.Generics as Hs +import qualified Proto3.Suite.Class as HsProtobuf +import qualified Proto3.Suite.DotProto as HsProtobuf +import Proto3.Suite.JSONPB ((.:), (.=)) +import qualified Proto3.Suite.JSONPB as HsJSONPB +import qualified Proto3.Suite.Types as HsProtobuf +import qualified Proto3.Wire as HsProtobuf +import qualified Unsafe.Coerce as Hs +import qualified Prelude as Hs + +data Timestamp = Timestamp + { timestampSeconds :: Hs.Int64, + timestampNanos :: Hs.Int32 + } + deriving (Hs.Show, Hs.Eq, Hs.Ord, Hs.Generic, Hs.NFData) + +instance HsProtobuf.Named Timestamp where + nameOf _ = Hs.fromString "Timestamp" + +instance HsProtobuf.HasDefault Timestamp + +instance HsProtobuf.Message Timestamp where + encodeMessage + _ + Timestamp + { timestampSeconds = timestampSeconds, + timestampNanos = timestampNanos + } = + Hs.mconcat + [ HsProtobuf.encodeMessageField + (HsProtobuf.FieldNumber 1) + timestampSeconds, + HsProtobuf.encodeMessageField + (HsProtobuf.FieldNumber 2) + timestampNanos + ] + + decodeMessage _ = + Timestamp + <$> HsProtobuf.at + HsProtobuf.decodeMessageField + (HsProtobuf.FieldNumber 1) + <*> HsProtobuf.at + HsProtobuf.decodeMessageField + (HsProtobuf.FieldNumber 2) + + dotProto _ = + [ HsProtobuf.DotProtoField + (HsProtobuf.FieldNumber 1) + (HsProtobuf.Prim HsProtobuf.Int64) + (HsProtobuf.Single "seconds") + [] + "", + HsProtobuf.DotProtoField + (HsProtobuf.FieldNumber 2) + (HsProtobuf.Prim HsProtobuf.Int32) + (HsProtobuf.Single "nanos") + [] + "" + ] + +rfc3339Format :: Hs.String +rfc3339Format = "%FT%TZ" + +fromUTCTime :: Time.UTCTime -> Timestamp +fromUTCTime utc = Timestamp sec (Hs.fromInteger (Hs.toInteger nano)) + where + Time.MkSystemTime sec nano = Time.utcToSystemTime utc + +toUTCTime :: Timestamp -> Time.UTCTime +toUTCTime (Timestamp sec nano) = Time.systemToUTCTime systemTime + where + systemTime = Time.MkSystemTime sec (Hs.fromInteger (Hs.toInteger nano)) + +fromRFC3339 :: Hs.Text -> Hs.Maybe Timestamp +fromRFC3339 txt = do + Time.MkSystemTime sec nano <- Time.utcToSystemTime <$> utcM + Hs.pure (Timestamp sec (Hs.fromInteger (Hs.toInteger nano))) + where + utcM = Time.parseTimeM Hs.False Time.defaultTimeLocale rfc3339Format (Text.unpack txt) + +toRFC3339 :: Timestamp -> Hs.Text +toRFC3339 ts = Text.pack (Time.formatTime Time.defaultTimeLocale rfc3339Format (toUTCTime ts)) + +instance HsJSONPB.ToJSONPB Timestamp where + toJSONPB ts _opt = HsJSONPB.String (Text.toStrict (toRFC3339 ts)) + +instance HsJSONPB.FromJSONPB Timestamp where + parseJSONPB = Aeson.withText "Timestamp" tryParse + where + tryParse txt = Hs.maybe Hs.mzero Hs.pure (fromRFC3339 (Text.fromStrict txt)) + +instance HsJSONPB.ToJSON Timestamp where + toJSON = HsJSONPB.toAesonValue + toEncoding = HsJSONPB.toAesonEncoding + +instance HsJSONPB.FromJSON Timestamp where + parseJSON = HsJSONPB.parseJSONPB + +instance HsJSONPB.ToSchema Timestamp where + declareNamedSchema _ = + do + let declare_seconds = HsJSONPB.declareSchemaRef + timestampSeconds <- declare_seconds Proxy.Proxy + let declare_nanos = HsJSONPB.declareSchemaRef + timestampNanos <- declare_nanos Proxy.Proxy + let _ = + Timestamp <$> HsJSONPB.asProxy declare_seconds + <*> HsJSONPB.asProxy declare_nanos + Hs.return + ( HsJSONPB.NamedSchema + { HsJSONPB._namedSchemaName = + Hs.Just "Timestamp", + HsJSONPB._namedSchemaSchema = + Hs.mempty + { HsJSONPB._schemaParamSchema = + Hs.mempty + { HsJSONPB._paramSchemaType = + Hs.Just HsJSONPB.SwaggerObject + }, + HsJSONPB._schemaProperties = + HsJSONPB.insOrdFromList + [ ("seconds", timestampSeconds), + ("nanos", timestampNanos) + ] + } + } + ) diff --git a/src/Proto3/Suite/Class.hs b/src/Proto3/Suite/Class.hs --- a/src/Proto3/Suite/Class.hs +++ b/src/Proto3/Suite/Class.hs @@ -576,6 +576,37 @@ decodeMessageField = decodePacked Decode.packedVarints protoType _ = messageField (Repeated Int64) (Just DotProto.PackedField) +instance MessageField (PackedVec (Signed Int32)) where + encodeMessageField fn = omittingDefault (Encode.packedVarintsV zigZag fn) . coerce @_ @(Vector Int32) + where + zigZag = fromIntegral . Encode.zigZagEncode + + decodeMessageField = decodePacked (fmap (fmap zagZig) Decode.packedVarints) + where + -- This type signature is important: `Decode.zigZagDecode` will not undo + -- `Encode.zigZagEncode` if given a signed value with the high order bit + -- set. So we don't allow GHC to infer a signed input type. + zagZig :: Word32 -> Signed Int32 + zagZig = Signed . fromIntegral . Decode.zigZagDecode + + protoType _ = messageField (Repeated SInt32) (Just DotProto.PackedField) + +instance MessageField (PackedVec (Signed Int64)) where + encodeMessageField fn = omittingDefault (Encode.packedVarintsV zigZag fn) . coerce @_ @(Vector Int64) + where + zigZag = fromIntegral . Encode.zigZagEncode + + decodeMessageField = decodePacked (fmap (fmap zagZig) Decode.packedVarints) + where + -- This type signature is important: `Decode.zigZagDecode` will not undo + -- `Encode.zigZagEncode` if given a signed value with the high order bit + -- set. So we don't allow GHC to infer a signed input type. + zagZig :: Word64 -> Signed Int64 + zagZig = Signed . fromIntegral . Decode.zigZagDecode + + protoType _ = messageField (Repeated SInt64) (Just DotProto.PackedField) + + instance MessageField (PackedVec (Fixed Word32)) where encodeMessageField fn = omittingDefault (Encode.packedFixed32V id fn) . coerce @_ @(Vector Word32) decodeMessageField = coerce @(Parser RawField (PackedVec Word32)) diff --git a/src/Proto3/Suite/DotProto/Generate.hs b/src/Proto3/Suite/DotProto/Generate.hs --- a/src/Proto3/Suite/DotProto/Generate.hs +++ b/src/Proto3/Suite/DotProto/Generate.hs @@ -124,9 +124,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} - {-# OPTIONS_GHC -fno-warn-unused-imports #-} - {-# OPTIONS_GHC -fno-warn-name-shadowing #-} - {-# OPTIONS_GHC -fno-warn-unused-matches #-} + {-# OPTIONS_GHC -fno-warn-unused-imports #-} + {-# OPTIONS_GHC -fno-warn-name-shadowing #-} + {-# OPTIONS_GHC -fno-warn-unused-matches #-} + {-# OPTIONS_GHC -fno-warn-missing-export-lists #-} -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! |] diff --git a/test-files/with_repeated_signed.bin b/test-files/with_repeated_signed.bin new file mode 100644 Binary files /dev/null and b/test-files/with_repeated_signed.bin differ diff --git a/tests/ArbitraryGeneratedTestTypes.hs b/tests/ArbitraryGeneratedTestTypes.hs --- a/tests/ArbitraryGeneratedTestTypes.hs +++ b/tests/ArbitraryGeneratedTestTypes.hs @@ -46,6 +46,9 @@ instance Arbitrary WithRepetition where arbitrary = WithRepetition <$> arbitrary +instance Arbitrary WithRepeatedSigned where + arbitrary = WithRepeatedSigned <$> arbitrary <*> arbitrary + instance Arbitrary WithFixed where arbitrary = WithFixed <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -92,6 +92,7 @@ , testProperty "WithEnum" (prop :: MsgProp TP.WithEnum) , testProperty "WithNesting" (prop :: MsgProp TP.WithNesting) , testProperty "WithRepetition" (prop :: MsgProp TP.WithRepetition) + , testProperty "WithRepeatedSigned" (prop :: MsgProp TP.WithRepeatedSigned) , testProperty "WithFixed" (prop :: MsgProp TP.WithFixed) , testProperty "WithBytes" (prop :: MsgProp TP.WithBytes) , testProperty "AllPackedTypes" (prop :: MsgProp TP.AllPackedTypes) @@ -132,6 +133,7 @@ , check "with_enum0.bin" $ TP.WithEnum $ Enumerated $ Right $ TP.WithEnum_TestEnumENUM1 , check "with_enum1.bin" $ TP.WithEnum $ Enumerated $ Right $ TP.WithEnum_TestEnumENUM2 , check "with_repetition.bin" $ TP.WithRepetition [1..5] + , check "with_repeated_signed.bin" $ TP.WithRepeatedSigned [0,1,-1,2,-2] [0,1,-1,2,-2] , check "with_bytes.bin" $ TP.WithBytes (BC.pack "abc") (fromList $ map BC.pack ["abc","123"]) , check "with_nesting_repeated.bin" $ TP.WithNestingRepeated [ TP.WithNestingRepeated_Nested "123abc" 123456 [1,2,3,4] [5,6,7,8] @@ -186,6 +188,7 @@ , check "with_enum0.bin" $ TP.WithEnum $ Enumerated $ Right $ TP.WithEnum_TestEnumENUM1 , check "with_enum1.bin" $ TP.WithEnum $ Enumerated $ Right $ TP.WithEnum_TestEnumENUM2 , check "with_repetition.bin" $ TP.WithRepetition [1..5] + , check "with_repeated_signed.bin" $ TP.WithRepeatedSigned [0,1,-1,2,-2] [0,1,-1,2,-2] , check "with_fixed.bin" $ TP.WithFixed 16 (-123) 4096 (-4096) , check "with_bytes.bin" $ TP.WithBytes (BC.pack "abc") (fromList $ map BC.pack ["abc","123"]) , check "with_packing.bin" $ TP.WithPacking [1,2,3] [1,2,3] diff --git a/tests/TestCodeGen.hs b/tests/TestCodeGen.hs --- a/tests/TestCodeGen.hs +++ b/tests/TestCodeGen.hs @@ -19,6 +19,7 @@ import Data.Swagger (ToSchema) import qualified Data.Swagger import qualified Data.Text as T +import Google.Protobuf.Timestamp (Timestamp(..)) import Prelude hiding (FilePath) import Proto3.Suite.DotProto.Generate import Proto3.Suite.DotProto (fieldLikeName, prefixedEnumFieldName, typeLikeName) @@ -37,12 +38,23 @@ [ camelCaseMessageNames , camelCaseMessageFieldNames , don'tAlterEnumFieldNames + , knownTypeMessages {- - These tests have been temporarily removed to pass CI. , simpleEncodeDotProto , simpleDecodeDotProto -} ] + +knownTypeMessages :: TestTree +knownTypeMessages = + testGroup + "KnownType custom codec" + [ testCase "Timestamp rfc3339 json encoding" + $ encode defaultOptions (Timestamp 0 0) @?= "\"1970-01-01T00:00:00Z\"" + , testCase "Timestamp rfc3339 json decoding" + $ eitherDecode "\"1970-01-01T00:00:00Z\"" @?= Right (Timestamp 0 0) + ] camelCaseMessageNames :: TestTree camelCaseMessageNames = testGroup "CamelCasing of message names"