Merge pull request #4878 from IntersectMBO/lehins/upgrade-cborg

Upgrade `cborg` dependency

libs/cardano-ledger-binary/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.6.0.0
 
+* Add `DecCBOR` instance for `Annotated a ByteString`
+* Add `originalBytesExpectedFailureMessage` needed for testing
 * Add `decodeListLikeWithCountT`
 * Add `internMap`, `internSet`, ` internsFromSet`
 * Add `DecShareCBOR` for  `Set`

libs/cardano-ledger-binary/cardano-ledger-binary.cabal

@@ -60,7 +60,7 @@ library
     cardano-crypto-praos >=2.2,
     cardano-slotting >=0.2,
     cardano-strict-containers >=0.1.2,
-    cborg >=0.2.9,
+    cborg >=0.2.10,
     containers,
     data-fix,
     deepseq,

libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Annotated.hs

@@ -95,6 +95,9 @@ instance ToJSON b => ToJSON (Annotated b a) where
 instance FromJSON b => FromJSON (Annotated b ()) where
   parseJSON j = flip Annotated () <$> parseJSON j
 
+instance DecCBOR a => DecCBOR (Annotated a BSL.ByteString) where
+  decCBOR = decodeAnnotated decCBOR
+
 -- | A decoder for a value paired with an annotation specifying the start and end
 -- of the consumed bytes.
 annotatedDecoder :: Decoder s a -> Decoder s (Annotated a ByteSpan)

libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs

@@ -18,6 +18,7 @@ module Cardano.Ledger.Binary.Decoding.Decoder (
   withPlainDecoder,
   enforceDecoderVersion,
   getOriginalBytes,
+  originalBytesExpectedFailureMessage,
   DecoderError (..),
   C.ByteOffset,
   ByteArray (..),
@@ -340,9 +341,15 @@ getOriginalBytes :: Decoder s BSL.ByteString
 getOriginalBytes =
   Decoder $ \maybeBytes _ ->
     case maybeBytes of
-      Nothing -> fail "Decoder was expected to provide the original ByteString"
+      Nothing -> fail originalBytesExpectedFailureMessage
       Just bsl -> pure bsl
 
+-- | This is the message that will be reported by `getOriginalBytes` when original bytes are not
+-- provided. It is defined as a separate biding for testing.
+originalBytesExpectedFailureMessage :: String
+originalBytesExpectedFailureMessage =
+  "Decoder was expected to provide the original ByteString"
+
 --------------------------------------------------------------------------------
 -- Working with current decoder version
 --------------------------------------------------------------------------------

libs/cardano-ledger-binary/test/Test/Cardano/Ledger/Binary/RoundTripSpec.hs

@@ -46,11 +46,13 @@ import Cardano.Crypto.VRF.Mock (MockVRF)
 import Cardano.Crypto.VRF.Praos (PraosVRF)
 import Cardano.Crypto.VRF.Simple (SimpleVRF)
 import Cardano.Ledger.Binary
+import qualified Cardano.Ledger.Binary.Plain as Plain
 import Cardano.Slotting.Block (BlockNo)
 import Cardano.Slotting.Slot (EpochNo, EpochSize, SlotNo, WithOrigin)
 import Cardano.Slotting.Time (SystemStart)
 import Codec.CBOR.ByteArray.Sliced (SlicedByteArray (..))
 import Control.Monad (when)
+import qualified Data.ByteString.Lazy as BSL
 import Data.Fixed (Nano, Pico)
 import Data.Foldable as F
 import Data.IP (IPv4, IPv6)
@@ -75,6 +77,27 @@ import Numeric.Natural
 import Test.Cardano.Ledger.Binary.Arbitrary ()
 import Test.Cardano.Ledger.Binary.RoundTrip
 import Test.Hspec
+import Test.QuickCheck
+
+-- This type is for testing roundtripping of types that need access to their bytes. The first field
+-- is a boolean indicator that decides whether we should use the actual type of interest (it is
+-- Float in here) or the preencoded bytes whenever we do the encoding. The last type is there just
+-- so we have some data that follows, whcih ensures out offsets are used correctly
+data SubBytes = SubBytes Bool (Annotated Float BSL.ByteString) (Maybe Word)
+  deriving (Eq, Show)
+
+instance Arbitrary SubBytes where
+  arbitrary = do
+    f <- arbitrary
+    let fAnn = Annotated f (Plain.serialize f)
+    SubBytes <$> arbitrary <*> pure fAnn <*> arbitrary
+
+instance DecCBOR SubBytes where
+  decCBOR = SubBytes <$> decCBOR <*> decCBOR <*> decCBOR
+
+instance EncCBOR SubBytes where
+  encCBOR (SubBytes x (Annotated y ybs) z) =
+    encCBOR x <> (if x then encCBOR y else encodePreEncoded (BSL.toStrict ybs)) <> encCBOR z
 
 spec :: Spec
 spec = do
@@ -116,6 +139,7 @@ spec = do
     roundTripSpec @Prim.ByteArray cborTrip
     roundTripSpec @ByteArray cborTrip
     roundTripSpec @SlicedByteArray cborTrip
+    roundTripSpec @SubBytes cborTrip
     roundTripSpec @(Maybe Integer) $
       mkTrip (encodeNullMaybe encCBOR) (decodeNullMaybe decCBOR)
     roundTripSpec @(StrictMaybe Integer) $

libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/RoundTrip.hs

@@ -522,14 +522,13 @@ embedTripLabelExtra lbl encVersion decVersion (Trip encoder decoder dropper) s =
         Right val
           | Nothing <- mDropperError ->
               let flatTerm = CBOR.toFlatTerm encoding
-                  plainDecoder = toPlainDecoder (Just encodedBytes) decVersion decoder
+                  -- We must not pass original bytes, because FlatTerm can't handle offsets
+                  plainDecoder = toPlainDecoder Nothing decVersion decoder
                in case CBOR.fromFlatTerm plainDecoder flatTerm of
-                    Left _err ->
-                      -- Until we switch to a release of cborg that includes a fix for this issue:
-                      -- https://github.com/well-typed/cborg/issues/324
-                      -- We can't rely on FlatTerm decoding
-                      -- Left $ mkFailure (Just $ "fromFlatTerm error:" <> err) Nothing Nothing
-                      Right (val, encoding, encodedBytes)
+                    Left err
+                      | err == originalBytesExpectedFailureMessage -> Right (val, encoding, encodedBytes)
+                      | otherwise ->
+                          Left $ mkFailure (Just $ "fromFlatTerm error:" <> err) Nothing Nothing
                     Right valFromFlatTerm
                       | val /= valFromFlatTerm ->
                           let errMsg =
@@ -542,10 +541,9 @@ embedTripLabelExtra lbl encVersion decVersion (Trip encoder decoder dropper) s =
                                   ++ "FlatTerm for the type is not valid"
                            in Left $ mkFailure (Just errMsg) Nothing Nothing
                       | otherwise -> Right (val, encoding, encodedBytes)
-          --  else Left $ mkFailure Nothing Nothing
           | Just err <- mDropperError -> Left $ mkFailure Nothing (Just err) Nothing
         Left err ->
-          -- In case of failure we only record dropper error if it differs from the
+          -- In case of failure we only record dropper error iff it differs from the
           -- decoder failure:
           let mErr = do
                 dropperError <- mDropperError