diff --git a/eras/byron/ledger/impl/src/Cardano/Chain/Byron/API/Common.hs b/eras/byron/ledger/impl/src/Cardano/Chain/Byron/API/Common.hs index 34c9f484ffc..4d25ab86170 100644 --- a/eras/byron/ledger/impl/src/Cardano/Chain/Byron/API/Common.hs +++ b/eras/byron/ledger/impl/src/Cardano/Chain/Byron/API/Common.hs @@ -106,7 +106,7 @@ reAnnotateUsing :: f a -> f ByteString reAnnotateUsing encoder decoder = - (\bs -> splice bs $ CBOR.deserialiseFromBytes (toPlainDecoder byronProtVer decoder) bs) + (\bs -> splice bs $ CBOR.deserialiseFromBytes (toPlainDecoder (Just bs) byronProtVer decoder) bs) . CBOR.toLazyByteString . toPlainEncoding byronProtVer . encoder diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs index 21c7ae6b6a9..1bb14a259d9 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs @@ -58,7 +58,6 @@ import Cardano.Ledger.Binary ( encodeListLen, encodeNullStrictMaybe, encodeWord8, - toPlainDecoder, toPlainEncoding, ) import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), ( FromCBOR (ConwayTxCert era) where - fromCBOR = toPlainDecoder (eraProtVerLow @era) decCBOR + fromCBOR = fromEraCBOR @era instance ( ConwayEraTxCert era diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Genesis.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Genesis.hs index f8e3effd7ea..addc7a1c50f 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Genesis.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Genesis.hs @@ -478,7 +478,7 @@ instance Crypto c => ToCBOR (ShelleyGenesis c) where <> encCBOR sgStaking instance Crypto c => FromCBOR (ShelleyGenesis c) where - fromCBOR = toPlainDecoder shelleyProtVer $ do + fromCBOR = toPlainDecoder Nothing shelleyProtVer $ do decodeRecordNamed "ShelleyGenesis" (const 15) $ do sgSystemStart <- decCBOR sgNetworkMagic <- decCBOR diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs index 2f698b24ba2..aa0d7868811 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs @@ -41,7 +41,6 @@ import Cardano.Ledger.Binary ( enforceDecoderVersion, ifDecoderVersionAtLeast, natVersion, - toPlainDecoder, ) import Cardano.Ledger.Binary.Coders (Decode (From, RecD), Encode (..), decode, encode, (!>), ( ToCBOR (UTxOState era) where toCBOR = toEraCBOR @era instance (EraTxOut era, EraGov era) => FromCBOR (UTxOState era) where - fromCBOR = toPlainDecoder (eraProtVerLow @era) decNoShareCBOR + fromCBOR = fromEraShareCBOR @era instance (EraTxOut era, EraGov era) => ToJSON (UTxOState era) where toJSON = object . toUTxOStatePairs @@ -556,7 +555,7 @@ instance (EraTxOut era, EraGov era) => ToCBOR (LedgerState era) where toCBOR = toEraCBOR @era instance (EraTxOut era, EraGov era) => FromCBOR (LedgerState era) where - fromCBOR = toPlainDecoder (eraProtVerLow @era) decNoShareCBOR + fromCBOR = fromEraShareCBOR @era instance (EraTxOut era, EraGov era) => ToJSON (LedgerState era) where toJSON = object . toLedgerStatePairs diff --git a/libs/cardano-ledger-binary/CHANGELOG.md b/libs/cardano-ledger-binary/CHANGELOG.md index de11f2552c5..659da3fbe33 100644 --- a/libs/cardano-ledger-binary/CHANGELOG.md +++ b/libs/cardano-ledger-binary/CHANGELOG.md @@ -2,6 +2,9 @@ ## 1.5.0.0 +* Add `decodeAnnotated` +* Add `getOriginalBytes` +* `toPlainDecoder` now optionally expects one extra argument for the original `ByteString` * Extend `Coders` to accommodate `{Enc|Dec}CBORGroup`. #4666 * Add `ToGroup` to `Encode` * Add `FromGroup` to `Decode` diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding.hs index 30e9e92aac8..182f6b60017 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding.hs @@ -45,7 +45,7 @@ where import Cardano.Ledger.Binary.Decoding.Annotated import Cardano.Ledger.Binary.Decoding.DecCBOR -import Cardano.Ledger.Binary.Decoding.Decoder +import Cardano.Ledger.Binary.Decoding.Decoder hiding (getOriginalBytes) import Cardano.Ledger.Binary.Decoding.Drop import Cardano.Ledger.Binary.Decoding.Sharing import Cardano.Ledger.Binary.Decoding.Sized @@ -143,8 +143,9 @@ deserialiseDecoder :: (forall s. Decoder s a) -> BSL.ByteString -> Either (Read.DeserialiseFailure, BS.ByteString) (a, BS.ByteString) -deserialiseDecoder version decoder bs0 = - runST (supplyAllInput bs0 =<< Read.deserialiseIncremental (toPlainDecoder version decoder)) +deserialiseDecoder version decoder bsl = + runST $ + supplyAllInput bsl =<< Read.deserialiseIncremental (toPlainDecoder (Just bsl) version decoder) {-# INLINE deserialiseDecoder #-} supplyAllInput :: diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Annotated.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Annotated.hs index df089d64ae5..6a0e467f445 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Annotated.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Annotated.hs @@ -12,6 +12,7 @@ module Cardano.Ledger.Binary.Decoding.Annotated ( Annotated (..), + decodeAnnotated, ByteSpan (..), Decoded (..), annotationBytes, @@ -34,6 +35,7 @@ import Cardano.Ledger.Binary.Decoding.Decoder ( decodeList, decodeWithByteSpan, fromPlainDecoder, + getOriginalBytes, setTag, whenDecoderVersionAtLeast, ) @@ -113,6 +115,12 @@ annotationBytes bytes = fmap (BSL.toStrict . slice bytes) reAnnotate :: EncCBOR a => Version -> Annotated a b -> Annotated a BS.ByteString reAnnotate version (Annotated x _) = Annotated x (serialize' version x) +decodeAnnotated :: Decoder s a -> Decoder s (Annotated a BSL.ByteString) +decodeAnnotated decoder = do + bsl <- getOriginalBytes + fmap (slice bsl) <$> annotatedDecoder decoder +{-# INLINE decodeAnnotated #-} + class Decoded t where type BaseType t :: Type recoverBytes :: t -> BS.ByteString diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/DecCBOR.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/DecCBOR.hs index 9b41743131c..00fc9993dfc 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/DecCBOR.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/DecCBOR.hs @@ -120,9 +120,9 @@ instance DecCBOR Version where {-# INLINE decCBOR #-} -- | Convert a versioned `DecCBOR` instance to a plain `Plain.Decoder` using Byron protocol --- version. +-- version and empty `BSL.ByteString`. fromByronCBOR :: DecCBOR a => Plain.Decoder s a -fromByronCBOR = toPlainDecoder byronProtVer decCBOR +fromByronCBOR = toPlainDecoder Nothing byronProtVer decCBOR {-# INLINE fromByronCBOR #-} -------------------------------------------------------------------------------- diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs index 99953ea205b..9f0b745c60e 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs @@ -17,6 +17,7 @@ module Cardano.Ledger.Binary.Decoding.Decoder ( fromPlainDecoder, withPlainDecoder, enforceDecoderVersion, + getOriginalBytes, DecoderError (..), C.ByteOffset, C.DecodeAction (..), @@ -278,25 +279,25 @@ import Prelude hiding (decodeFloat) -------------------------------------------------------------------------------- newtype Decoder s a = Decoder - { runDecoder :: Version -> C.Decoder s a + { runDecoder :: Maybe BSL.ByteString -> Version -> C.Decoder s a } instance Functor (Decoder s) where - fmap f (Decoder d) = Decoder (fmap f . d) + fmap f d = Decoder (\bsl v -> f <$> runDecoder d bsl v) {-# INLINE fmap #-} instance Applicative (Decoder s) where - pure x = Decoder (const (pure x)) + pure x = Decoder (\_ _ -> pure x) {-# INLINE pure #-} - Decoder f <*> Decoder g = Decoder $ \v -> f v <*> g v + Decoder f <*> Decoder g = Decoder $ \bsl v -> f bsl v <*> g bsl v {-# INLINE (<*>) #-} - Decoder f *> Decoder g = Decoder $ \v -> f v *> g v + Decoder f *> Decoder g = Decoder $ \bsl v -> f bsl v *> g bsl v {-# INLINE (*>) #-} instance Monad (Decoder s) where - Decoder f >>= g = Decoder $ \v -> do - x <- f v - runDecoder (g x) v + Decoder f >>= g = Decoder $ \bsl v -> do + x <- f bsl v + runDecoder (g x) bsl v {-# INLINE (>>=) #-} instance MonadFail (Decoder s) where @@ -306,24 +307,40 @@ instance MonadFail (Decoder s) where -- | Promote a regular `C.Decoder` to a versioned one. Which means it will work for all -- versions. fromPlainDecoder :: C.Decoder s a -> Decoder s a -fromPlainDecoder d = Decoder (const d) +fromPlainDecoder d = Decoder (\_ _ -> d) {-# INLINE fromPlainDecoder #-} --- | Extract the underlying `C.Decoder` by specifying the concrete version to be used. -toPlainDecoder :: Version -> Decoder s a -> C.Decoder s a -toPlainDecoder v (Decoder d) = d v +-- | Extract the underlying `C.Decoder` by optionally supplying the original bytes and +-- specifying the concrete version to be used. +toPlainDecoder :: + -- | Some decoders require the original bytes to be supplied as well. Such decoders will + -- fail whenever `Nothing` is supplied. + Maybe BSL.ByteString -> + Version -> + Decoder s a -> + C.Decoder s a +toPlainDecoder bsl v (Decoder d) = d bsl v {-# INLINE toPlainDecoder #-} -- | Use the supplied decoder as a plain decoder with current version. withPlainDecoder :: Decoder s a -> (C.Decoder s a -> C.Decoder s b) -> Decoder s b -withPlainDecoder vd f = Decoder $ \curVersion -> f (toPlainDecoder curVersion vd) +withPlainDecoder vd f = Decoder $ \bsl -> f . runDecoder vd bsl {-# INLINE withPlainDecoder #-} -- | Ignore the current version of the decoder and enforce the supplied one instead. enforceDecoderVersion :: Version -> Decoder s a -> Decoder s a -enforceDecoderVersion version = fromPlainDecoder . toPlainDecoder version +enforceDecoderVersion version d = Decoder $ \bsl _ -> runDecoder d bsl version {-# INLINE enforceDecoderVersion #-} +-- | Lookup the original bytes that are being used for deserialization. This action will +-- fail deserialization whenever original bytes are not available. +getOriginalBytes :: Decoder s BSL.ByteString +getOriginalBytes = + Decoder $ \maybeBytes _ -> + case maybeBytes of + Nothing -> fail "Decoder was expected to provide the original ByteString" + Just bsl -> pure bsl + -------------------------------------------------------------------------------- -- Working with current decoder version -------------------------------------------------------------------------------- @@ -334,7 +351,7 @@ enforceDecoderVersion version = fromPlainDecoder . toPlainDecoder version -- >>> decodeFullDecoder 3 "Version" getDecoderVersion "" -- Right 3 getDecoderVersion :: Decoder s Version -getDecoderVersion = Decoder pure +getDecoderVersion = Decoder $ \_ -> pure {-# INLINE getDecoderVersion #-} -- | Conditionally choose the newer or older decoder, depending on the current diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/FlatTerm.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/FlatTerm.hs index db834997d9d..762d071ce29 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/FlatTerm.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/FlatTerm.hs @@ -17,4 +17,4 @@ toFlatTerm :: Version -> Encoding -> C.FlatTerm toFlatTerm version = C.toFlatTerm . toPlainEncoding version fromFlatTerm :: Version -> (forall s. Decoder s a) -> C.FlatTerm -> Either String a -fromFlatTerm version decoder = C.fromFlatTerm (toPlainDecoder version decoder) +fromFlatTerm version decoder = C.fromFlatTerm (toPlainDecoder mempty version decoder) diff --git a/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/RoundTrip.hs b/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/RoundTrip.hs index 30678c78797..9343663f5c1 100644 --- a/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/RoundTrip.hs +++ b/libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/RoundTrip.hs @@ -522,7 +522,8 @@ embedTripLabelExtra lbl encVersion decVersion (Trip encoder decoder dropper) s = Right val | Nothing <- mDropperError -> let flatTerm = CBOR.toFlatTerm encoding - in case CBOR.fromFlatTerm (toPlainDecoder decVersion decoder) flatTerm of + plainDecoder = toPlainDecoder (Just encodedBytes) 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 diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index dd4dcb0bdb2..bd79bc0a0b1 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,9 @@ ## 1.16.0.0 +* Remove requirement for `FromCBOR` instance for `TxOut` in `EraTxOut` +* Add `decodeMemoized` +* Add `DecCBOR` instance for `MemoBytes` * Add `VRFVerKeyHash` and `KeyRoleVRF`. * Switch `genDelegVrfHash`, `individualPoolStakeVrf` and `ppVrf` to using `VRFVerKeyHash`. * Add `{Enc|Dec}CBORGroup` instances for `Mismatch`. #4666 diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs index 3503623dec8..606a57d6b92 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs @@ -81,7 +81,6 @@ import Cardano.Ledger.Binary ( DecShareCBOR (Share), EncCBOR, EncCBORGroup, - FromCBOR, Interns, Sized (sizedValue), ToCBOR, @@ -276,7 +275,6 @@ class , DecCBOR (CompactForm (Value era)) , EncCBOR (Value era) , ToCBOR (TxOut era) - , FromCBOR (TxOut era) , EncCBOR (TxOut era) , DecCBOR (TxOut era) , DecShareCBOR (TxOut era) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/Era.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/Era.hs index f3b805a80c8..b9a388d0f08 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/Era.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/Era.hs @@ -275,25 +275,34 @@ notSupportedInThisEraL :: HasCallStack => Lens' a b notSupportedInThisEraL = lens notSupportedInThisEra notSupportedInThisEra -- | Convert a type that implements `EncCBOR` to plain `Plain.Encoding` using the lowest --- protocol version for the supplied @era@ +-- protocol version for the supplied @era@. toEraCBOR :: forall era t. (Era era, EncCBOR t) => t -> Plain.Encoding toEraCBOR = toPlainEncoding (eraProtVerLow @era) . encCBOR {-# INLINE toEraCBOR #-} -- | Convert a type that implements `DecCBOR` to plain `Plain.Decoder` using the lowest -- protocol version for the supplied @era@ +-- +-- This action should not be used for decoders that require access to original bytes, use +-- `toPlainDecoder` instead. fromEraCBOR :: forall era t s. (Era era, DecCBOR t) => Plain.Decoder s t fromEraCBOR = eraDecoder @era decCBOR {-# INLINE fromEraCBOR #-} -- | Convert a type that implements `DecShareCBOR` to plain `Plain.Decoder` using the lowest -- protocol version for the supplied @era@ +-- +-- This action should not be used for decoders that require access to original bytes, use +-- `toPlainDecoder` instead. fromEraShareCBOR :: forall era t s. (Era era, DecShareCBOR t) => Plain.Decoder s t fromEraShareCBOR = eraDecoder @era decNoShareCBOR {-# INLINE fromEraShareCBOR #-} -- | Convert a versioned `Decoder` to plain a `Plain.Decoder` using the lowest protocol -- version for the supplied @era@ +-- +-- This action should not be used for decoders that require access to original bytes, use +-- `toPlainDecoder` instead. eraDecoder :: forall era t s. Era era => Decoder s t -> Plain.Decoder s t -eraDecoder = toPlainDecoder (eraProtVerLow @era) +eraDecoder = toPlainDecoder Nothing (eraProtVerLow @era) {-# INLINE eraDecoder #-} diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes.hs index 00473bb5c9e..75b7ed5b564 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes.hs @@ -21,6 +21,7 @@ module Cardano.Ledger.MemoBytes ( -- * Memoized Memoized (RawType), mkMemoized, + decodeMemoized, getMemoSafeHash, getMemoRawType, zipMemoRawType, diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs index eeb12d0c9c0..ff1eb4aa5ef 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs @@ -44,6 +44,7 @@ module Cardano.Ledger.MemoBytes.Internal ( -- * Memoized Memoized (RawType), mkMemoized, + decodeMemoized, getMemoSafeHash, getMemoRawType, zipMemoRawType, @@ -59,9 +60,12 @@ where import Cardano.Crypto.Hash (HashAlgorithm (hashAlgorithmName)) import Cardano.Ledger.Binary ( + Annotated (..), Annotator (..), DecCBOR (decCBOR), + Decoder, EncCBOR, + decodeAnnotated, serialize, withSlice, ) @@ -115,16 +119,16 @@ instance (Typeable t, Typeable era) => Plain.ToCBOR (MemoBytes t era) where toCBOR (Memo' _ bytes _hash) = Plain.encodePreEncoded (fromShort bytes) instance - ( Typeable t - , DecCBOR (Annotator (t era)) - , Era era - ) => + (Typeable t, DecCBOR (Annotator (t era)), Era era) => DecCBOR (Annotator (MemoBytes t era)) where decCBOR = do (Annotator getT, Annotator getBytes) <- withSlice decCBOR pure (Annotator (\fullbytes -> mkMemoBytes (getT fullbytes) (getBytes fullbytes))) +instance (Typeable t, DecCBOR (t era), Era era) => DecCBOR (MemoBytes t era) where + decCBOR = decodeMemoized decCBOR + -- | Both binary representation and Haskell types are compared. instance Eq (t era) => Eq (MemoBytes t era) where x == y = mbBytes x == mbBytes y && mbRawType x == mbRawType y @@ -216,6 +220,11 @@ class Memoized t where mkMemoized :: forall era t. (Era era, EncCBOR (RawType t era), Memoized t) => RawType t era -> t era mkMemoized rawType = wrapMemoBytes (mkMemoBytes rawType (serialize (eraProtVerLow @era) rawType)) +decodeMemoized :: Era era => Decoder s (t era) -> Decoder s (MemoBytes t era) +decodeMemoized rawTypeDecoder = do + Annotated rawType lazyBytes <- decodeAnnotated rawTypeDecoder + pure $ mkMemoBytes rawType lazyBytes + -- | Extract memoized SafeHash getMemoSafeHash :: Memoized t => t era -> SafeHash (EraCrypto era) (MemoHashIndex (RawType t)) getMemoSafeHash t = mbHash (getMemoBytes t) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Evaluate.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Evaluate.hs index b24df9eef3d..54066b5a1ea 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Evaluate.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Evaluate.hs @@ -180,7 +180,7 @@ instance Crypto c => ToCBOR (PlutusWithContext c) where instance Crypto c => FromCBOR (PlutusWithContext c) where fromCBOR = Plain.decodeRecordNamed "PlutusWithContext" (const 6) $ do pwcProtocolVersion <- fromCBOR - toPlainDecoder pwcProtocolVersion $ decodeWithPlutus $ \plutus -> do + toPlainDecoder Nothing pwcProtocolVersion $ decodeWithPlutus $ \plutus -> do let lang = plutusLanguage plutus pwcScript = Left plutus scriptHash = hashPlutusScript plutus