wireform-proto-0.1.0.0: test-integration/Test/WellKnown.hs
module Test.WellKnown (wellKnownTests) where
import Data.Aeson qualified as Aeson
import Data.ByteString qualified as BS
import Data.Hashable (hash, hashWithSalt)
import Data.Proxy (Proxy (..))
import Data.Vector qualified as V
import Hedgehog
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import Proto
import Proto
import Proto.Google.Protobuf.WellKnownTypes.Any
import Proto.Google.Protobuf.WellKnownTypes.Any.Util
import Proto.Google.Protobuf.WellKnownTypes.Duration
import Proto.Google.Protobuf.WellKnownTypes.Empty
import Proto.Google.Protobuf.WellKnownTypes.FieldMask
import Proto.Google.Protobuf.WellKnownTypes.SourceContext
import Proto.Google.Protobuf.WellKnownTypes.Struct
import Proto.Google.Protobuf.WellKnownTypes.Timestamp
import Proto.Google.Protobuf.WellKnownTypes.Wrappers
import Proto.Registry (TypeRegistry, emptyRegistry, lookupCodec, lookupDecoder, registerMessage)
import Test.Tasty
import Test.Tasty.HUnit hiding (assert)
import Test.Tasty.Hedgehog
wellKnownTests :: TestTree
wellKnownTests =
testGroup
"Well-Known Types"
[ testGroup
"Timestamp"
[ testProperty "roundtrip" $ property $ do
s <- forAll $ Gen.int64 (Range.linear (-1000000000) 1000000000)
n <- forAll $ Gen.int32 (Range.linear 0 999999999)
let msg = defaultTimestamp {timestampSeconds = s, timestampNanos = n}
encoded = encodeMessage msg
decodeMessage encoded === Right msg
, testCase "default is zero-length" $ do
let encoded = encodeMessage defaultTimestamp
BS.length encoded @?= 0
, testCase "sized encoding matches" $ do
let msg = defaultTimestamp {timestampSeconds = 1234567890, timestampNanos = 123456789}
BS.length (encodeMessage msg) @?= messageSize msg
, testCase "JSON canonical RFC 3339" $ do
let msg = defaultTimestamp {timestampSeconds = 1708000000, timestampNanos = 0}
Aeson.toJSON msg @?= Aeson.String "2024-02-15T12:26:40Z"
, testCase "JSON with nanos" $ do
let msg = defaultTimestamp {timestampSeconds = 0, timestampNanos = 123456789}
Aeson.toJSON msg @?= Aeson.String "1970-01-01T00:00:00.123456789Z"
, testCase "JSON nanos trailing zeros trimmed" $ do
let msg = defaultTimestamp {timestampSeconds = 0, timestampNanos = 100000000}
Aeson.toJSON msg @?= Aeson.String "1970-01-01T00:00:00.1Z"
]
, testGroup
"Duration"
[ testProperty "roundtrip" $ property $ do
s <- forAll $ Gen.int64 (Range.linear (-315576000000) 315576000000)
n <- forAll $ Gen.int32 (Range.linear (-999999999) 999999999)
let msg = defaultDuration {durationSeconds = s, durationNanos = n}
encoded = encodeMessage msg
decodeMessage encoded === Right msg
, testCase "JSON canonical seconds" $ do
let msg = defaultDuration {durationSeconds = 3600, durationNanos = 0}
Aeson.toJSON msg @?= Aeson.String "3600s"
, testCase "JSON with nanos" $ do
let msg = defaultDuration {durationSeconds = 1, durationNanos = 500000000}
Aeson.toJSON msg @?= Aeson.String "1.5s"
, testCase "JSON negative" $ do
let msg = defaultDuration {durationSeconds = -1, durationNanos = -500000000}
Aeson.toJSON msg @?= Aeson.String "-1.5s"
]
, testGroup
"Any"
[ testProperty "raw Any roundtrip" $ property $ do
tu <- forAll $ Gen.text (Range.linear 0 100) Gen.alphaNum
v <- forAll $ Gen.bytes (Range.linear 0 200)
let msg = defaultAny {anyTypeUrl = tu, anyValue = v}
encoded = encodeMessage msg
decodeMessage encoded === Right msg
, testProperty "packAny Timestamp roundtrip" $ property $ do
s <- forAll $ Gen.int64 (Range.linear 0 2000000000)
n <- forAll $ Gen.int32 (Range.linear 0 999999999)
let ts = defaultTimestamp {timestampSeconds = s, timestampNanos = n}
packed = packAny ts
anyTypeUrl packed === "type.googleapis.com/google.protobuf.Timestamp"
case unpackAny packed of
Just (Right decoded) -> decoded === ts
Just (Left err) -> do annotate (show err); failure
Nothing -> do annotate "type mismatch"; failure
, testProperty "packAny Duration roundtrip" $ property $ do
s <- forAll $ Gen.int64 (Range.linear 0 1000000)
n <- forAll $ Gen.int32 (Range.linear 0 999999999)
let dur = defaultDuration {durationSeconds = s, durationNanos = n}
packed = packAny dur
case unpackAny packed of
Just (Right decoded) -> decoded === dur
_ -> failure
, testCase "packAny Empty" $ do
let packed = packAny defaultEmpty
anyTypeUrl packed @?= "type.googleapis.com/google.protobuf.Empty"
case unpackAny packed :: Maybe (Either DecodeError Empty) of
Just (Right _) -> pure ()
other -> assertFailure ("Expected Just (Right Empty), got " <> show other)
, testCase "unpackAny type mismatch returns Nothing" $ do
let packed = packAny (defaultTimestamp {timestampSeconds = 100})
case unpackAny packed :: Maybe (Either DecodeError Duration) of
Nothing -> pure ()
Just _ -> assertFailure "Should not match Duration"
, testCase "isMessageType" $ do
let packed = packAny (defaultDuration {durationSeconds = 60})
isMessageType (Proxy :: Proxy Duration) packed @?= True
isMessageType (Proxy :: Proxy Timestamp) packed @?= False
, testCase "typeNameFromUrl strips prefix" $ do
typeNameFromUrl "type.googleapis.com/google.protobuf.Timestamp"
@?= "google.protobuf.Timestamp"
typeNameFromUrl "mycompany.com/types/example.Foo"
@?= "example.Foo"
typeNameFromUrl "google.protobuf.Timestamp"
@?= "google.protobuf.Timestamp"
, testCase "packAnyWithPrefix custom prefix" $ do
let packed = packAnyWithPrefix "myhost/" (defaultTimestamp {timestampSeconds = 1})
anyTypeUrl packed @?= "myhost/google.protobuf.Timestamp"
case unpackAny packed of
Just (Right ts) -> ts @?= defaultTimestamp {timestampSeconds = 1}
_ -> assertFailure "Should unpack with any prefix"
, testCase "Any wire roundtrip preserves content" $ do
let ts = defaultTimestamp {timestampSeconds = 1234567890, timestampNanos = 500000000}
packed = packAny ts
encodedAny = encodeMessage packed
case decodeMessage encodedAny of
Left err -> assertFailure (show err)
Right decodedAny -> case unpackAny decodedAny of
Just (Right (decoded :: Timestamp)) -> decoded @?= ts
_ -> assertFailure "Should unpack after wire roundtrip"
, testCase "TypeRegistry codec lookup" $ do
let registry =
registerMessage (Proxy :: Proxy Timestamp)
. registerMessage (Proxy :: Proxy Duration)
. registerMessage (Proxy :: Proxy Empty)
$ emptyRegistry
case lookupDecoder @Timestamp "google.protobuf.Timestamp" registry of
Just decode' -> case decode' (encodeMessage (defaultTimestamp {timestampSeconds = 42})) of
Right ts -> timestampSeconds ts @?= 42
Left e -> assertFailure (show e)
Nothing -> assertFailure "Should find Timestamp decoder"
, testCase "TypeRegistry unknown type returns Nothing" $ do
let registry = registerMessage (Proxy :: Proxy Timestamp) emptyRegistry
case lookupCodec "unknown.Type" registry of
Nothing -> pure ()
Just _ -> assertFailure "Should return Nothing for unknown type"
]
, testGroup
"Empty"
[ testCase "empty roundtrip" $ do
let encoded = encodeMessage defaultEmpty
BS.length encoded @?= 0
case decodeMessage encoded :: Either DecodeError Empty of
Right _ -> pure ()
Left e -> assertFailure (show e)
]
, testGroup
"Wrappers"
[ testProperty "Int64Value roundtrip" $ property $ do
v <- forAll $ Gen.int64 Range.linearBounded
let msg = defaultInt64Value {int64ValueValue = v}
decodeMessage (encodeMessage msg) === Right msg
, testProperty "UInt64Value roundtrip" $ property $ do
v <- forAll $ Gen.word64 (Range.linear 0 maxBound)
let msg = defaultUInt64Value {uInt64ValueValue = v}
decodeMessage (encodeMessage msg) === Right msg
, testProperty "Int32Value roundtrip" $ property $ do
v <- forAll $ Gen.int32 Range.linearBounded
let msg = defaultInt32Value {int32ValueValue = v}
decodeMessage (encodeMessage msg) === Right msg
, testProperty "BoolValue roundtrip" $ property $ do
v <- forAll Gen.bool
let msg = defaultBoolValue {boolValueValue = v}
decodeMessage (encodeMessage msg) === Right msg
, testProperty "StringValue roundtrip" $ property $ do
v <- forAll $ Gen.text (Range.linear 0 100) Gen.unicode
let msg = defaultStringValue {stringValueValue = v}
decodeMessage (encodeMessage msg) === Right msg
, testProperty "BytesValue roundtrip" $ property $ do
v <- forAll $ Gen.bytes (Range.linear 0 200)
let msg = defaultBytesValue {bytesValueValue = v}
decodeMessage (encodeMessage msg) === Right msg
, testProperty "DoubleValue roundtrip" $ property $ do
v <- forAll $ Gen.double (Range.linearFrac (-1e100) 1e100)
let msg = defaultDoubleValue {doubleValueValue = v}
decodeMessage (encodeMessage msg) === Right msg
, testProperty "FloatValue roundtrip" $ property $ do
v <- forAll $ Gen.float (Range.linearFrac (-1e30) 1e30)
let msg = defaultFloatValue {floatValueValue = v}
decodeMessage (encodeMessage msg) === Right msg
]
, testGroup
"FieldMask"
[ testCase "roundtrip" $ do
let msg = defaultFieldMask {fieldMaskPaths = V.fromList ["foo.bar", "baz"]}
encoded = encodeMessage msg
decodeMessage encoded @?= Right msg
]
, testGroup
"SourceContext"
[ testProperty "roundtrip" $ property $ do
fn <- forAll $ Gen.text (Range.linear 0 100) Gen.alphaNum
let msg = defaultSourceContext {sourceContextFileName = fn}
decodeMessage (encodeMessage msg) === Right msg
]
, testGroup
"Struct"
[ testCase "empty struct roundtrip" $ do
let msg = defaultStruct
decodeMessage (encodeMessage msg) @?= Right msg
, testCase "value null roundtrip" $ do
let v = defaultValue {valueKind = Just (Value'Kind'NullValue NullValue'NullValue)}
decodeMessage (encodeMessage v) @?= Right v
, testCase "value number roundtrip" $ do
let v = defaultValue {valueKind = Just (Value'Kind'NumberValue 3.14)}
decodeMessage (encodeMessage v) @?= Right v
, testCase "value string roundtrip" $ do
let v = defaultValue {valueKind = Just (Value'Kind'StringValue "hello")}
decodeMessage (encodeMessage v) @?= Right v
, testCase "value bool roundtrip" $ do
let v = defaultValue {valueKind = Just (Value'Kind'BoolValue True)}
decodeMessage (encodeMessage v) @?= Right v
, testCase "list value roundtrip" $ do
let lv =
defaultListValue
{ listValueValues =
V.fromList
[ defaultValue {valueKind = Just (Value'Kind'NumberValue 1)}
, defaultValue {valueKind = Just (Value'Kind'StringValue "two")}
, defaultValue {valueKind = Just (Value'Kind'BoolValue False)}
]
}
decodeMessage (encodeMessage lv) @?= Right lv
]
, testGroup
"Hashable instances"
[ testProperty "Timestamp: equal values have equal hashes" $ property $ do
s <- forAll $ Gen.int64 (Range.linear 0 1000000)
n <- forAll $ Gen.int32 (Range.linear 0 999999)
let msg = defaultTimestamp {timestampSeconds = s, timestampNanos = n}
hash msg === hash msg
, testCase "Timestamp: different values have different hashes" $ do
let m1 = defaultTimestamp {timestampSeconds = 100}
m2 = defaultTimestamp {timestampSeconds = 200}
assertBool "hashes should differ" (hash m1 /= hash m2)
, testCase "Duration: hashWithSalt works" $ do
let msg = defaultDuration {durationSeconds = 42, durationNanos = 123}
hashWithSalt 0 msg `seq` pure ()
, testCase "Empty: hashable" $ do
hash defaultEmpty `seq` pure ()
, testProperty "FieldMask: hashable with vector field" $ property $ do
ps <- forAll $ Gen.list (Range.linear 0 5) (Gen.text (Range.linear 1 10) Gen.alphaNum)
let msg = defaultFieldMask {fieldMaskPaths = V.fromList ps}
hash msg `seq` pure ()
, testProperty "Struct: hashable with map field" $ property $ do
hash defaultStruct `seq` pure ()
]
]