wireform-proto-0.3.0.0: test-regression/Main.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Main (main) where

import Control.Exception (ErrorCall, evaluate)
import Control.Monad (forM_)
import Data.Aeson qualified as Aeson
import Data.Aeson.Types qualified as Aeson
import Data.ByteString qualified as BS
import Data.Either (isLeft)
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Generated.Edition2023 qualified as G23
import Generated.Edition2024 qualified as G24
import Generated.Integermaps qualified as GM
import Proto.CodeGen
import Proto.Decode
import Proto.Encode
import Proto.IDL.Parser
import Proto.IDL.Parser.Resolver (ResolvedProto (..))
import Proto.Internal.JSON qualified as JSON
import THFixtures qualified as TH
import Test.Syd


main :: IO ()
main = sydTest $ do
  describe "Editions field presence" $ do
    it "standalone codegen preserves every explicitly present scalar default" $
      forM_ scalarDefaults $
        roundtrip @G23.Fields23
    it "loadProto preserves every explicitly present scalar default" $
      forM_ scalarDefaults $
        roundtrip @TH.Fields23
    it "absent and explicitly zero fields remain distinct in both generators" $ do
      fmap G23.fields23Count (decodeMessage BS.empty) `shouldBe` Right Nothing
      fmap G23.fields23Count (decodeMessage (BS.pack [8, 0])) `shouldBe` Right (Just 0)
      fmap TH.fields23Count (decodeMessage BS.empty) `shouldBe` Right Nothing
      fmap TH.fields23Count (decodeMessage (BS.pack [8, 0])) `shouldBe` Right (Just 0)
    it "file and field overrides, aggregate options and nested messages agree" $ do
      forM_ [BS.pack [16, 0], BS.pack [26, 2, 16, 0]] $ roundtrip @G24.Fields24
      forM_ [BS.pack [16, 0], BS.pack [26, 2, 16, 0]] $ roundtrip @TH.Fields24
      fmap G24.fields24Count (decodeMessage (BS.pack [8, 0])) `shouldBe` Right 0
      fmap TH.fields24Count (decodeMessage (BS.pack [8, 0])) `shouldBe` Right 0
      fmap encodeMessage (decodeMessage (BS.pack [8, 0]) :: Either DecodeError G24.Fields24) `shouldBe` Right BS.empty
      fmap encodeMessage (decodeMessage (BS.pack [8, 0]) :: Either DecodeError TH.Fields24) `shouldBe` Right BS.empty
      fmap encodeMessage (decodeMessage (BS.pack [64, 0, 112, 0]) :: Either DecodeError G23.Fields23) `shouldBe` Right BS.empty
      fmap encodeMessage (decodeMessage (BS.pack [64, 0, 112, 0]) :: Either DecodeError TH.Fields23) `shouldBe` Right BS.empty
    it "repeated, map, oneof and nested fields retain their wire shapes" $ do
      forM_ collectionValues $ roundtrip @G23.Fields23
      forM_ collectionValues $ roundtrip @TH.Fields23
    it "merge preserves an explicitly present zero over a nonzero value" $ do
      case (decodeMessage (BS.pack [8, 7]), decodeMessage (BS.pack [8, 0])) of
        (Right a, Right b) -> encodeMessage (a <> b :: G23.Fields23) `shouldBe` BS.pack [8, 0]
        _ -> expectationFailure "standalone fixture decode failed"
      case (decodeMessage (BS.pack [8, 7]), decodeMessage (BS.pack [8, 0])) of
        (Right a, Right b) -> encodeMessage (a <> b :: TH.Fields23) `shouldBe` BS.pack [8, 0]
        _ -> expectationFailure "TH fixture decode failed"
    it "does not silently accept unsupported LEGACY_REQUIRED presence" $ do
      pf <-
        either (fail . show) pure $
          parseProtoFile
            "unsupported.proto"
            "edition = \"2023\"; message M { int32 x = 1 [features.field_presence = LEGACY_REQUIRED]; }"
      evaluate (T.length (generateModuleText defaultGenerateOpts Map.empty "unsupported.proto" pf))
        `shouldThrow` (\(_ :: ErrorCall) -> True)
    it "committed standalone fixtures exactly match the generator" $
      forM_ ["edition2023", "edition2024", "integerMaps"] $ \name -> do
        let file = name <> ".proto"
        source <- TIO.readFile ("test-regression/proto/" <> file)
        pf <- either (fail . show) pure (parseProtoFile file source)
        let opts = defaultGenerateOpts {genModulePrefix = "Generated"}
            registry = buildTypeRegistry opts [(file, ResolvedProto pf file Map.empty)]
        actual <- TIO.readFile ("test-regression/" <> T.unpack (T.replace "." "/" (moduleNameForProto opts file pf)) <> ".hs")
        actual `shouldBe` generateModuleText opts registry file pf
  describe "Standalone integer maps" $ do
    it "integer value functions compile and agree with TH for limits and zero" $
      forM_ integerMapValues $ \message -> do
        let wire = encodeMessage message
        decodeMessage wire `shouldBe` Right message
        messageSize message `shouldBe` BS.length wire
        encodeMessageSized message `shouldBe` wire
        fmap encodeMessage (decodeMessage wire :: Either DecodeError TH.IntegerMaps) `shouldBe` Right wire
    it "sint32 and sint64 map values use canonical ZigZag and exact sizes" $ do
      let small = GM.defaultIntegerMaps {GM.integerMapsSint32Values = Map.singleton "a" (-1)}
          large = GM.defaultIntegerMaps {GM.integerMapsSint64Values = Map.singleton "a" (-1)}
      encodeMessage small `shouldBe` BS.pack [42, 5, 10, 1, 97, 16, 1]
      encodeMessage large `shouldBe` BS.pack [50, 5, 10, 1, 97, 16, 1]
      messageSize small `shouldBe` 7
      messageSize large `shouldBe` 7
  describe "ProtoJSON quoted numbers" $ do
    it "generated Float and Double accept e/E and signed exponents" $
      forM_ (["1e2", "1E+2", "10000e-2", "1.0e2"] :: [T.Text]) $ \number -> do
        let json = Aeson.object ["value" Aeson..= number, "small" Aeson..= number]
        fmap TH.jsonNumbersValue (Aeson.parseEither Aeson.parseJSON json) `shouldBe` Right 100
        fmap TH.jsonNumbersSmall (Aeson.parseEither Aeson.parseJSON json) `shouldBe` Right 100
    it "optional and oneof floating fields use the same number grammar" $ do
      let json = "{\"optionalValue\":\"1e2\",\"selected\":\"1E2\"}"
      case Aeson.eitherDecode json of
        Left err -> expectationFailure err
        Right result -> do
          TH.jsonNumbersOptionalValue result `shouldBe` Just 100
          case TH.jsonNumbersChoice result of
            Just (TH.JsonNumbers'Choice'Selected value) -> value `shouldBe` 100
            _ -> expectationFailure "quoted oneof number was dropped"
    it "runtime float/double and int64 helpers accept quoted exponents" $ do
      Aeson.parseEither JSON.protoDoubleFromJSON (Aeson.String "1e2") `shouldBe` Right 100
      Aeson.parseEither JSON.protoFloatFromJSON (Aeson.String "1E2") `shouldBe` Right 100
      Aeson.parseEither JSON.protoInt64FromJSON (Aeson.String "1e2") `shouldBe` Right 100
      Aeson.parseEither JSON.protoWord64FromJSON (Aeson.String "1E2") `shouldBe` Right 100
    it "rejects whitespace, trailing junk, noncanonical sentinels and overflow" $
      forM_ ["", " 1", "1 ", "1e", "1e2x", "nan", "NAN", "+nan", "-nan", " NaN", "NaN ", "inf", "INF", "+Infinity", " Infinity", "Infinity ", "-inf", "-INF", " -Infinity", "-Infinity ", "1e1000"] $ \number -> do
        isLeft (Aeson.parseEither JSON.protoDoubleFromJSON (Aeson.String number)) `shouldBe` True
        isLeft (Aeson.parseEither JSON.protoFloatFromJSON (Aeson.String number)) `shouldBe` True
        isLeft (Aeson.parseEither Aeson.parseJSON (Aeson.object ["value" Aeson..= number]) :: Either String TH.JsonNumbers) `shouldBe` True
    it "retains canonical NaN/Infinity strings" $ do
      fmap isNaN (Aeson.parseEither JSON.protoDoubleFromJSON (Aeson.String "NaN")) `shouldBe` Right True
      fmap isInfinite (Aeson.parseEither JSON.protoDoubleFromJSON (Aeson.String "Infinity")) `shouldBe` Right True
      Aeson.parseEither JSON.protoDoubleFromJSON (Aeson.String "-Infinity") `shouldBe` Right (negate (1 / 0))


scalarDefaults :: [BS.ByteString]
scalarDefaults = fmap BS.pack [[8, 0], [18, 0], [26, 0], [32, 0], [40, 0], [49, 0, 0, 0, 0, 0, 0, 0, 0], [61, 0, 0, 0, 0]]


collectionValues :: [BS.ByteString]
collectionValues = fmap BS.pack [[74, 2, 1, 2], [82, 2, 8, 0], [90, 6, 10, 1, 97, 18, 1, 98], [96, 0], [106, 0]]


roundtrip :: forall a. (MessageDecode a, MessageEncode a) => BS.ByteString -> IO ()
roundtrip wire = fmap (encodeMessage @a) (decodeMessage wire) `shouldBe` Right wire


integerMapValues :: [GM.IntegerMaps]
integerMapValues =
  [ GM.defaultIntegerMaps {GM.integerMapsInt32Values = Map.fromList [("a", minBound), ("b", 0), ("c", maxBound)]}
  , GM.defaultIntegerMaps {GM.integerMapsInt64Values = Map.fromList [("a", minBound), ("b", 0), ("c", maxBound)]}
  , GM.defaultIntegerMaps {GM.integerMapsUint32Values = Map.fromList [("a", 0), ("b", maxBound)]}
  , GM.defaultIntegerMaps {GM.integerMapsUint64Values = Map.fromList [("a", 0), ("b", maxBound)]}
  , GM.defaultIntegerMaps {GM.integerMapsSint32Values = Map.fromList [("a", minBound), ("b", 0), ("c", maxBound)]}
  , GM.defaultIntegerMaps {GM.integerMapsSint64Values = Map.fromList [("a", minBound), ("b", 0), ("c", maxBound)]}
  , GM.defaultIntegerMaps {GM.integerMapsSfixed32Values = Map.fromList [("a", minBound), ("b", 0), ("c", maxBound)]}
  , GM.defaultIntegerMaps {GM.integerMapsSfixed64Values = Map.fromList [("a", minBound), ("b", 0), ("c", maxBound)]}
  , GM.defaultIntegerMaps {GM.integerMapsFixed32Values = Map.fromList [("a", 0), ("b", maxBound)]}
  , GM.defaultIntegerMaps {GM.integerMapsFixed64Values = Map.fromList [("a", 0), ("b", maxBound)]}
  , GM.defaultIntegerMaps {GM.integerMapsIntegerKeys = Map.fromList [(minBound, minBound), (0, 0), (maxBound, maxBound)]}
  , GM.defaultIntegerMaps {GM.integerMapsZigzagKeys = Map.fromList [(minBound, "min"), (0, "zero"), (maxBound, "max")]}
  ]