From 8341406a22ff0dc4d7e7d342101447a2c26acfab Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 29 Jan 2025 08:16:26 +0000 Subject: [PATCH 01/32] [temp] - disable 8.10.7 on CI --- .github/workflows/haskell.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 0d0179fea90..7b5b9e1a1d8 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -36,7 +36,7 @@ jobs: build: strategy: matrix: - ghc: ["8.10.7", "9.2.8", "9.6.6", "9.8.4", "9.10.1"] + ghc: ["9.2.8", "9.6.6", "9.8.4", "9.10.1"] os: [ubuntu-latest] fail-fast: false @@ -213,7 +213,7 @@ jobs: - set-algebra - small-steps - vector-map - ghc: ["8.10.7", "9.2.8", "9.6.6", "9.8.4", "9.10.1"] + ghc: ["9.2.8", "9.6.6", "9.8.4", "9.10.1"] os: [ubuntu-latest] fail-fast: false From da93e985cc1b8c907be9d4c1346d5fa194900024 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 29 Jan 2025 14:25:59 +0000 Subject: [PATCH 02/32] Remove redundant constraint from DecCBOR instance for AlonzoTxWitsRaw --- eras/alonzo/impl/CHANGELOG.md | 1 + eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs | 4 +--- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/eras/alonzo/impl/CHANGELOG.md b/eras/alonzo/impl/CHANGELOG.md index 546be593d88..882998733af 100644 --- a/eras/alonzo/impl/CHANGELOG.md +++ b/eras/alonzo/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.13.0.0 +* Remove redundant `EncCBOR (Data era)` constraint from `DecCBOR` instance for `Annotator (AlonzoTxWits era)` * Add `TxInfoResult` data family, `mkTxInfoResult` and `lookupTxInfoResult` to `EraPlutusContext` * Add `lookupTxInfoResultImpossible` helper * Add `TxInfoResult era` parameter to `toPlutusWithContext` and `mkPlutusWithContext` diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs index 4a6b175ad9b..6db1d86a49f 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs @@ -609,9 +609,7 @@ deriving via AlonzoEraScript era => DecCBOR (Annotator (Redeemers era)) instance - ( AlonzoEraScript era - , EncCBOR (Data era) - ) => + AlonzoEraScript era => DecCBOR (Annotator (AlonzoTxWitsRaw era)) where decCBOR = From 43367edc1b600154f44dc0830e1710d221a25f73 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 29 Jan 2025 14:23:40 +0000 Subject: [PATCH 03/32] Extract local bindings used to build TxWits decoder as function so that they can be reused --- .../impl/src/Cardano/Ledger/Alonzo/TxWits.hs | 110 +++++++++--------- 1 file changed, 57 insertions(+), 53 deletions(-) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs index 6db1d86a49f..9f95857c0ed 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs @@ -205,6 +205,9 @@ unRedeemers = unRedeemersRaw . getMemoRawType nullRedeemers :: Redeemers era -> Bool nullRedeemers = Map.null . unRedeemers +emptyTxWitness :: AlonzoEraScript era => AlonzoTxWitsRaw era +emptyTxWitness = AlonzoTxWitsRaw mempty mempty mempty mempty emptyRedeemers + emptyRedeemers :: AlonzoEraScript era => Redeemers era emptyRedeemers = Redeemers mempty @@ -608,6 +611,11 @@ deriving via instance AlonzoEraScript era => DecCBOR (Annotator (Redeemers era)) +deriving via + Mem (AlonzoTxWitsRaw era) + instance + AlonzoEraScript era => DecCBOR (Annotator (AlonzoTxWits era)) + instance AlonzoEraScript era => DecCBOR (Annotator (AlonzoTxWitsRaw era)) @@ -620,8 +628,6 @@ instance txWitnessField [] where - emptyTxWitness = AlonzoTxWitsRaw mempty mempty mempty mempty emptyRedeemers - txWitnessField :: Word -> Field (Annotator (AlonzoTxWitsRaw era)) txWitnessField 0 = fieldAA @@ -671,59 +677,57 @@ instance where pairDecoder :: Decoder s (Annotator (ScriptHash, Script era)) pairDecoder = fmap (asHashedPair . fromNativeScript) <$> decCBOR - - addScripts :: - Map ScriptHash (Script era) -> - AlonzoTxWitsRaw era -> - AlonzoTxWitsRaw era - addScripts scriptWitnesses txWits = - txWits - { atwrScriptTxWits = scriptWitnesses <> atwrScriptTxWits txWits - } - {-# INLINE addScripts #-} - - decodePlutus :: - PlutusLanguage l => - SLanguage l -> - Decode ('Closed 'Dense) (Map ScriptHash (Script era)) - decodePlutus slang = - D $ - ifDecoderVersionAtLeast - (natVersion @9) - (scriptDecoderV9 (fromPlutusScript <$> decodePlutusScript slang)) - (scriptDecoder (fromPlutusScript <$> decodePlutusScript slang)) - {-# INLINE decodePlutus #-} - - scriptDecoderV9 :: - Decoder s (Script era) -> - Decoder s (Map ScriptHash (Script era)) - scriptDecoderV9 decodeScript = do - allowTag setTag - scriptMap <- decodeMapLikeEnforceNoDuplicates decodeListLenOrIndef $ do - asHashedPair <$> decodeScript - when (Map.null scriptMap) $ fail "Empty list of scripts is not allowed" - pure scriptMap - {-# INLINE scriptDecoderV9 #-} - - scriptDecoder :: - Decoder s (Script era) -> - Decoder s (Map ScriptHash (Script era)) - scriptDecoder decodeScript = - fmap Map.fromList $ - decodeList $ - asHashedPair <$> decodeScript - {-# INLINE scriptDecoder #-} - - asHashedPair script = - let !scriptHash = hashScript @era script - in (scriptHash, script) - {-# INLINE asHashedPair #-} {-# INLINE decCBOR #-} -deriving via - Mem (AlonzoTxWitsRaw era) - instance - AlonzoEraScript era => DecCBOR (Annotator (AlonzoTxWits era)) +addScripts :: + Map ScriptHash (Script era) -> + AlonzoTxWitsRaw era -> + AlonzoTxWitsRaw era +addScripts scriptWitnesses txWits = + txWits + { atwrScriptTxWits = scriptWitnesses <> atwrScriptTxWits txWits + } +{-# INLINE addScripts #-} + +decodePlutus :: + (AlonzoEraScript era, PlutusLanguage l) => + SLanguage l -> + Decode ('Closed 'Dense) (Map ScriptHash (Script era)) +decodePlutus slang = + D $ + ifDecoderVersionAtLeast + (natVersion @9) + (scriptDecoderV9 (fromPlutusScript <$> decodePlutusScript slang)) + (scriptDecoder (fromPlutusScript <$> decodePlutusScript slang)) +{-# INLINE decodePlutus #-} + +scriptDecoderV9 :: + EraScript era => + Decoder s (Script era) -> + Decoder s (Map ScriptHash (Script era)) +scriptDecoderV9 decodeScript = do + allowTag setTag + scriptMap <- decodeMapLikeEnforceNoDuplicates decodeListLenOrIndef $ do + asHashedPair <$> decodeScript + when (Map.null scriptMap) $ fail "Empty list of scripts is not allowed" + pure scriptMap +{-# INLINE scriptDecoderV9 #-} + +scriptDecoder :: + EraScript era => + Decoder s (Script era) -> + Decoder s (Map ScriptHash (Script era)) +scriptDecoder decodeScript = + fmap Map.fromList $ + decodeList $ + asHashedPair <$> decodeScript +{-# INLINE scriptDecoder #-} + +asHashedPair :: forall era. EraScript era => Script era -> (ScriptHash, Script era) +asHashedPair script = + let !scriptHash = hashScript @era script + in (scriptHash, script) +{-# INLINE asHashedPair #-} alonzoEqTxWitsRaw :: AlonzoEraTxWits era => TxWits era -> TxWits era -> Bool alonzoEqTxWitsRaw txWits1 txWits2 = From 58d9f6241cdfdaf07ea65e964bfbe74c13f3b8ed Mon Sep 17 00:00:00 2001 From: teodanciu Date: Thu, 30 Jan 2025 14:24:01 +0000 Subject: [PATCH 04/32] Rename `segwitTx` to distinguish `Annotator` from simple version --- eras/shelley/impl/CHANGELOG.md | 1 + eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs | 4 ++-- eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs | 2 +- eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs | 6 +++--- 4 files changed, 7 insertions(+), 6 deletions(-) diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index f8717c41706..1cdacacb267 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.16.0.0 +* Rename `segwitTx` to `segWitAnnTx` * Move `AccountState` to `Cardano.Ledger.State` * Deprecated `RewardAccounts` * Deprecated `utxosUtxoL` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs index 499b8e9db19..0724a4a1a02 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs @@ -52,7 +52,7 @@ import Cardano.Ledger.Binary ( ) import Cardano.Ledger.Core import Cardano.Ledger.Shelley.Era (ShelleyEra) -import Cardano.Ledger.Shelley.Tx (ShelleyTx, segwitTx) +import Cardano.Ledger.Shelley.Tx (ShelleyTx, segWitAnnTx) import Cardano.Ledger.Slot (SlotNo (..)) import Control.Monad (unless) import Data.ByteString (ByteString) @@ -233,7 +233,7 @@ txSeqDecoder lax = do let txns = sequenceA $ StrictSeq.forceToStrict $ - Seq.zipWith3 segwitTx bodies wits metadata + Seq.zipWith3 segWitAnnTx bodies wits metadata pure $ TxSeq' <$> txns <*> bodiesAnn <*> witsAnn <*> metadataAnn instance EraTx era => DecCBOR (Annotator (ShelleyTxSeq era)) where diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs index cbd8cef60ac..13f821da55e 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs @@ -12,7 +12,7 @@ module Cardano.Ledger.Shelley.Tx ( auxDataShelleyTxL, sizeShelleyTxF, wireSizeShelleyTxF, - segwitTx, + segWitAnnTx, mkBasicShelleyTx, shelleyMinFeeTx, witsFromTxWitnesses, diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs index 980b758f467..6ff4ffd1fc4 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs @@ -39,7 +39,7 @@ module Cardano.Ledger.Shelley.Tx.Internal ( auxDataShelleyTxL, sizeShelleyTxF, wireSizeShelleyTxF, - segwitTx, + segWitAnnTx, mkBasicShelleyTx, shelleyMinFeeTx, witsFromTxWitnesses, @@ -348,14 +348,14 @@ unsafeConstructTxWithBytes b w a bytes = TxConstr (mkMemoBytes (ShelleyTxRaw b w -- Segregated witness -------------------------------------------------------------------------------- -segwitTx :: +segWitAnnTx :: forall era. EraTx era => Annotator (TxBody era) -> Annotator (TxWits era) -> Maybe (Annotator (TxAuxData era)) -> Annotator (ShelleyTx era) -segwitTx +segWitAnnTx bodyAnn witsAnn metaAnn = Annotator $ \bytes -> From 17bd173a6f2a2fa75b1ed07bf92d37ebc15e9305 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Tue, 21 Jan 2025 14:27:15 +0000 Subject: [PATCH 05/32] [core] PlutusData, Data, Bootstrap --- .../src/Cardano/Ledger/Keys/Bootstrap.hs | 41 +++++++++++++++---- .../src/Cardano/Ledger/MemoBytes/Internal.hs | 2 +- .../src/Cardano/Ledger/Plutus/Data.hs | 5 ++- 3 files changed, 38 insertions(+), 10 deletions(-) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs index 3ae83c4783b..f77b5c77434 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs @@ -60,10 +60,15 @@ import Cardano.Ledger.Keys.Internal ( VKey (..), verifySignedDSIGN, ) -import Cardano.Ledger.MemoBytes (EqRaw (..)) +import Cardano.Ledger.MemoBytes ( + EqRaw (..), + MemoBytes (Memo), + decodeMemoized, + ) import Control.DeepSeq (NFData) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Short as SBS import Data.Coerce (coerce) import Data.Maybe (fromMaybe) import Data.Ord (comparing) @@ -125,13 +130,33 @@ instance EncCBOR BootstrapWitness instance DecCBOR (Annotator BootstrapWitness) where decCBOR = annotatorSlice $ - decodeRecordNamed "BootstrapWitness" (const 4) $ - do - key <- decCBOR - sig <- decodeSignedDSIGN - cc <- decCBOR - attributes <- decCBOR - pure . pure $ BootstrapWitness' key sig cc attributes + decodeRecordNamed "BootstrapWitness" (const 4) $ do + key <- decCBOR + sig <- decodeSignedDSIGN + cc <- decCBOR + attributes <- decCBOR + pure . pure $ BootstrapWitness' key sig cc attributes + +data BootstrapWitnessRaw + = BootstrapWitnessRaw + !(VKey 'Witness) + !(SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)) + !ChainCode + !ByteString + +instance DecCBOR BootstrapWitnessRaw where + decCBOR = decodeRecordNamed "BootstrapWitnessRaw" (const 4) $ + do + key <- decCBOR + sig <- decodeSignedDSIGN + cc <- decCBOR + BootstrapWitnessRaw key sig cc <$> decCBOR + +instance DecCBOR BootstrapWitness where + decCBOR = do + mb <- decodeMemoized (decCBOR @BootstrapWitnessRaw) + let (Memo (BootstrapWitnessRaw k s c a) bs) = mb + pure $ BootstrapWitness' k s c a (LBS.fromStrict (SBS.fromShort bs)) -- | Rebuild the addrRoot of the corresponding address. bootstrapWitKeyHash :: 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 f05e776127d..7728e3f2b17 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/MemoBytes/Internal.hs @@ -246,7 +246,7 @@ class Memoized t where MemoBytes (RawType t) getMemoBytes = coerce - -- | This is a coercion from the MemoBytes to the momoized type. This implementation + -- | This is a coercion from the MemoBytes to the memoized type. This implementation -- cannot be changed since `warpMemoBytes` is not exported, therefore it will only work -- on newtypes around `MemoBytes` wrapMemoBytes :: MemoBytes (RawType t) -> t diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs index 175058b0bbc..40f4c6f7f63 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs @@ -94,9 +94,12 @@ instance Typeable era => EncCBOR (PlutusData era) where instance Typeable era => DecCBOR (Annotator (PlutusData era)) where decCBOR = pure <$> fromPlainDecoder Cborg.decode +instance Typeable era => DecCBOR (PlutusData era) where + decCBOR = fromPlainDecoder Cborg.decode + newtype Data era = DataConstr (MemoBytes (PlutusData era)) deriving (Eq, Generic) - deriving newtype (SafeToHash, ToCBOR, NFData) + deriving newtype (SafeToHash, ToCBOR, NFData, DecCBOR) -- | Encodes memoized bytes created upon construction. instance Typeable era => EncCBOR (Data era) From 24cb168dfbc728bc6888008b25c510bf465156ab Mon Sep 17 00:00:00 2001 From: teodanciu Date: Tue, 21 Jan 2025 14:57:07 +0000 Subject: [PATCH 06/32] [core] - WitVKey --- .../src/Cardano/Ledger/Keys/WitVKey.hs | 23 ++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/WitVKey.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/WitVKey.hs index 2c8f784b837..9c450134228 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/WitVKey.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/WitVKey.hs @@ -28,8 +28,10 @@ import Cardano.Ledger.Binary ( EncCBOR (..), ToCBOR (..), annotatorSlice, + decodeRecordNamed, fromPlainDecoder, ) +import qualified Cardano.Ledger.Binary.Crypto (decodeSignedDSIGN) import qualified Cardano.Ledger.Binary.Plain as Plain import Cardano.Ledger.Hashes ( EraIndependentTxBody, @@ -40,9 +42,10 @@ import Cardano.Ledger.Hashes ( hashTxBodySignature, ) import Cardano.Ledger.Keys.Internal (DSIGN, KeyRole (..), VKey, asWitness) -import Cardano.Ledger.MemoBytes (EqRaw (..)) +import Cardano.Ledger.MemoBytes (EqRaw (..), MemoBytes (Memo), decodeMemoized) import Control.DeepSeq import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Short as SBS import Data.Ord (comparing) import Data.Typeable (Typeable) import GHC.Generics (Generic) @@ -97,6 +100,24 @@ instance Typeable kr => DecCBOR (Annotator (WitVKey kr)) where {-# INLINE mkWitVKey #-} {-# INLINE decCBOR #-} +data WitVKeyRaw kr + = WitVKeyRaw + !(VKey kr) + !(SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)) + (KeyHash 'Witness) + +instance Typeable kr => DecCBOR (WitVKeyRaw kr) where + decCBOR = decodeRecordNamed "WitVKey" (const 2) $ do + key <- decCBOR + sig <- Cardano.Ledger.Binary.Crypto.decodeSignedDSIGN + pure $ WitVKeyRaw key sig (asWitness $ hashKey key) + +instance Typeable kr => DecCBOR (WitVKey kr) where + decCBOR = do + mb <- decodeMemoized (decCBOR @(WitVKeyRaw kr)) + let (Memo (WitVKeyRaw k s kh) bs) = mb + pure $ WitVKeyInternal k s kh (BSL.fromStrict (SBS.fromShort bs)) + instance Typeable kr => EqRaw (WitVKey kr) where eqRaw = eqWitVKeyRaw From 5473893076bbbaa64192f962063402eb5d118a92 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Tue, 21 Jan 2025 14:57:19 +0000 Subject: [PATCH 07/32] [allegra] - Timelock --- .../src/Cardano/Ledger/Allegra/Scripts.hs | 20 ++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs index d2b6ca945db..30b856c5246 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs @@ -76,6 +76,7 @@ import Cardano.Ledger.MemoBytes ( MemoBytes (Memo), Memoized (..), byteCountMemoBytes, + decodeMemoized, getMemoRawType, mkMemoBytes, mkMemoizedEra, @@ -189,9 +190,8 @@ instance Era era => EncCBOR (TimelockRaw era) where TimeStart m -> Sum TimeStart 4 !> To m TimeExpire m -> Sum TimeExpire 5 !> To m --- This instance allows us to derive instance DecCBOR (Annotator (Timelock crypto)). --- Since Timelock is a newtype around (Memo (Timelock crypto)). - +-- This instance allows us to derive instance DecCBOR (Annotator (Timelock era)). +-- Since Timelock is a newtype around (Memo (Timelock era)). instance Era era => DecCBOR (Annotator (TimelockRaw era)) where decCBOR = decode (Summands "TimelockRaw" decRaw) where @@ -204,6 +204,17 @@ instance Era era => DecCBOR (Annotator (TimelockRaw era)) where decRaw 5 = Ann (SumD TimeExpire DecCBOR (TimelockRaw era) where + decCBOR = decode (Summands "Timelock" decRaw) + where + decRaw 0 = SumD Signature MemPack (Timelock era) where instance Era era => NoThunks (Timelock era) instance Era era => EncCBOR (Timelock era) +instance Era era => DecCBOR (Timelock era) where + decCBOR = TimelockConstr <$> decodeMemoized decCBOR + instance Memoized (Timelock era) where type RawType (Timelock era) = TimelockRaw era From 0083d4749bd632117af86668fd328ba8210ee78d Mon Sep 17 00:00:00 2001 From: teodanciu Date: Thu, 23 Jan 2025 20:08:33 +0000 Subject: [PATCH 08/32] [shelley] - MultiSig --- .../src/Cardano/Ledger/Shelley/Scripts.hs | 20 +++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs index e228cf9fcff..32ddd364f6e 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Scripts.hs @@ -34,15 +34,18 @@ module Cardano.Ledger.Shelley.Scripts ( ) where -import Cardano.Ledger.BaseTypes (invalidKey) import Cardano.Ledger.Binary ( Annotator (..), DecCBOR (decCBOR), EncCBOR (..), ToCBOR, decodeRecordSum, + invalidKey, + ) +import Cardano.Ledger.Binary.Coders ( + Encode (Sum, To), + (!>), ) -import Cardano.Ledger.Binary.Coders (Encode (..), (!>)) import Cardano.Ledger.Core import Cardano.Ledger.Keys.WitVKey (witVKeyHash) import Cardano.Ledger.MemoBytes ( @@ -50,6 +53,7 @@ import Cardano.Ledger.MemoBytes ( Mem, MemoBytes, Memoized (..), + decodeMemoized, getMemoRawType, memoBytesEra, pattern Memo, @@ -188,6 +192,18 @@ pattern RequireMOf n ms <- (getRequireMOf -> Just (n, ms)) -- | Encodes memoized bytes created upon construction. instance Era era => EncCBOR (MultiSig era) +instance Era era => DecCBOR (MultiSig era) where + decCBOR = MultiSigConstr <$> decodeMemoized decCBOR + +instance Era era => DecCBOR (MultiSigRaw era) where + decCBOR = decodeRecordSum "MultiSig" $ do + \case + 0 -> (,) 2 . RequireSignature' . KeyHash <$> decCBOR + 1 -> (,) 2 . RequireAllOf' <$> decCBOR + 2 -> (,) 2 . RequireAnyOf' <$> decCBOR + 3 -> (,) 3 <$> (RequireMOf' <$> decCBOR <*> decCBOR) + k -> invalidKey k + instance Era era => DecCBOR (Annotator (MultiSigRaw era)) where decCBOR = decodeRecordSum "MultiSig" $ \case From 18c76a56870647ddd92a1a922b6b48c35b47333c Mon Sep 17 00:00:00 2001 From: teodanciu Date: Thu, 23 Jan 2025 20:08:51 +0000 Subject: [PATCH 09/32] [shelley] - ShelleyTxWits --- .../impl/src/Cardano/Ledger/Shelley/TxWits.hs | 33 ++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs index 2d2e2940561..633d7e3a6f6 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs @@ -62,6 +62,7 @@ import Cardano.Ledger.MemoBytes ( Mem, MemoBytes, Memoized (..), + decodeMemoized, getMemoRawType, lensMemoRawType, mkMemoizedEra, @@ -124,6 +125,9 @@ instance instance EraScript era => NoThunks (ShelleyTxWits era) +instance (EraScript era, DecCBOR (Script era)) => DecCBOR (ShelleyTxWits era) where + decCBOR = ShelleyTxWitsConstr <$> decodeMemoized decCBOR + -- ======================================================= -- Accessors -- ======================================================= @@ -224,11 +228,38 @@ deriving via instance EraScript era => DecCBOR (Annotator (ShelleyTxWits era)) +instance forall era. (EraScript era, DecCBOR (Script era)) => DecCBOR (ShelleyTxWitsRaw era) where + decCBOR = + decode $ + SparseKeyed + "ShelleyTxWits" + (ShelleyTxWitsRaw mempty mempty mempty) + witField + [] + where + witField :: Word -> Field (ShelleyTxWitsRaw era) + witField 0 = + field + (\x wits -> wits {addrWits' = x}) + (D $ withIgnoreSigOrd <$> decodeList decCBOR) + witField 1 = + field + (\x wits -> wits {scriptWits' = x}) + (D $ Map.fromElems (hashScript @era) <$> decodeList decCBOR) + witField 2 = + field + (\x wits -> wits {bootWits' = x}) + (D $ Set.fromList <$> decodeList decCBOR) + witField n = field (\_ wits -> wits) (Invalid n) + -- | This type is only used to preserve the old buggy behavior where signature -- was ignored in the `Ord` instance for `WitVKey`s. newtype IgnoreSigOrd kr = IgnoreSigOrd {unIgnoreSigOrd :: WitVKey kr} deriving (Eq) +withIgnoreSigOrd :: Typeable kr => [WitVKey kr] -> Set (WitVKey kr) +withIgnoreSigOrd = Set.map unIgnoreSigOrd . Set.fromList . fmap IgnoreSigOrd + instance Typeable kr => Ord (IgnoreSigOrd kr) where compare (IgnoreSigOrd w1) (IgnoreSigOrd w2) = compare (witVKeyHash w1) (witVKeyHash w2) @@ -252,7 +283,7 @@ decodeWits = ( D $ mapTraverseableDecoderA (decodeList decCBOR) - (Set.map unIgnoreSigOrd . Set.fromList . fmap IgnoreSigOrd) + withIgnoreSigOrd ) witField 1 = fieldAA From e362e6439f5f452cb48ada4f242fdbf5e2e56beb Mon Sep 17 00:00:00 2001 From: teodanciu Date: Fri, 24 Jan 2025 13:48:12 +0000 Subject: [PATCH 10/32] [shelley] - ShelleyTxAuxData --- eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs index ac37102c896..cd38f651940 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs @@ -82,7 +82,7 @@ deriving via newtype ShelleyTxAuxData era = AuxiliaryDataConstr (MemoBytes (ShelleyTxAuxDataRaw era)) deriving (Eq, Show, Generic) - deriving newtype (NFData, Plain.ToCBOR, SafeToHash) + deriving newtype (NFData, Plain.ToCBOR, SafeToHash, DecCBOR) instance Memoized (ShelleyTxAuxData era) where type RawType (ShelleyTxAuxData era) = ShelleyTxAuxDataRaw era From 1337c891ca60a2a23ab48a066be073322a8ceb78 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Fri, 24 Jan 2025 14:01:04 +0000 Subject: [PATCH 11/32] [shelley] - ShelleyTxBody --- eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs index bed981ead62..24896a930c8 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs @@ -310,6 +310,14 @@ deriving via instance EraTxBody era => DecCBOR (Annotator (ShelleyTxBody era)) +deriving newtype instance + ( Era era + , DecCBOR (PParamsUpdate era) + , DecCBOR (TxOut era) + , DecCBOR (TxCert era) + ) => + DecCBOR (ShelleyTxBody era) + -- | Pattern for use by external users pattern ShelleyTxBody :: forall era. From 32dcb3c898f3de4ecd7b32070a49c403f3bba07e Mon Sep 17 00:00:00 2001 From: teodanciu Date: Fri, 24 Jan 2025 14:15:11 +0000 Subject: [PATCH 12/32] [shelley] - ShelleyTx --- .../src/Cardano/Ledger/Shelley/Tx/Internal.hs | 22 +++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs index 6ff4ffd1fc4..0b1676edf8d 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs @@ -322,12 +322,34 @@ instance ( sequence . maybeToStrictMaybe <$> decodeNullMaybe decCBOR ) +instance + ( Era era + , DecCBOR (TxBody era) + , DecCBOR (TxWits era) + , DecCBOR (TxAuxData era) + ) => + DecCBOR (ShelleyTxRaw era) + where + decCBOR = + decode $ + RecD ShelleyTxRaw + decodeNullMaybe decCBOR) deriving via Mem (ShelleyTxRaw era) instance EraTx era => DecCBOR (Annotator (ShelleyTx era)) +deriving newtype instance + ( Era era + , DecCBOR (TxBody era) + , DecCBOR (TxWits era) + , DecCBOR (TxAuxData era) + ) => + DecCBOR (ShelleyTx era) + -- | Construct a Tx containing the explicit serialised bytes. -- -- This function is marked as unsafe since it makes no guarantee that the From 32e05b6fd0e5f1b11378cb37cb46b42062a0cfc2 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Fri, 24 Jan 2025 14:56:24 +0000 Subject: [PATCH 13/32] [core] - BHeader --- .../src/Cardano/Protocol/TPraos/BHeader.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs b/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs index c344d51d2fe..a32e19e4e27 100644 --- a/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs +++ b/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/BHeader.hs @@ -90,6 +90,7 @@ import Cardano.Ledger.Hashes ( hashKey, ) import Cardano.Ledger.Keys (VKey) +import Cardano.Ledger.MemoBytes (MemoBytes (Memo), decodeMemoized) import Cardano.Ledger.NonIntegral (CompareResult (..), taylorExpCmp) import Cardano.Ledger.Slot (BlockNo (..), SlotNo (..)) import Cardano.Protocol.Crypto @@ -100,6 +101,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BS import qualified Data.ByteString.Builder.Extra as BS import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Short as SBS import Data.Typeable import Data.Word (Word32, Word64) import GHC.Generics (Generic) @@ -292,6 +294,20 @@ instance Crypto c => DecCBOR (Annotator (BHeader c)) where sig <- decodeSignedKES pure $ pure $ BHeader' bhb sig . BSL.toStrict +data BHeaderRaw c = BHeaderRaw !(BHBody c) !(KES.SignedKES (KES c) (BHBody c)) + +instance Crypto c => DecCBOR (BHeaderRaw c) where + decCBOR = decodeRecordNamed "Header" (const 2) $ do + bhb <- decCBOR + sig <- decodeSignedKES + pure $ BHeaderRaw bhb sig + +instance Crypto c => DecCBOR (BHeader c) where + decCBOR = do + mb <- decodeMemoized decCBOR + let (Memo (BHeaderRaw bhb sig) bs) = mb + pure $ BHeader' bhb sig (SBS.fromShort bs) + -- | Hash a given block header bhHash :: Crypto c => BHeader c -> HashHeader bhHash bh = HashHeader . Hash.castHash . hashEncCBOR version $ bh From a7621c8a8dbb524db80a7f78730716f8e9e8a7a2 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Mon, 27 Jan 2025 13:30:10 +0000 Subject: [PATCH 14/32] [core] - Block --- .../src/Cardano/Ledger/Block.hs | 33 +++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs index 7f16dd04268..9bd44e1b3e8 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs @@ -34,8 +34,10 @@ import Cardano.Ledger.Binary ( ) import qualified Cardano.Ledger.Binary.Plain as Plain import Cardano.Ledger.Core +import Cardano.Ledger.MemoBytes (MemoBytes (Memo), decodeMemoized) import Cardano.Ledger.TxIn (TxIn (..)) import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Short as SBS import Data.Foldable (toList) import Data.Set (Set) import qualified Data.Set as Set @@ -134,6 +136,37 @@ instance 1 -- header + fromIntegral (numSegComponents @era) +data BlockRaw h era = BlockRaw !h !(TxSeq era) + +instance + forall h era. + ( EraSegWits era + , DecCBOR h + , DecCBOR (TxSeq era) + ) => + DecCBOR (BlockRaw h era) + where + decCBOR = + decodeRecordNamed "Block" (const blockSize) $ do + header <- decCBOR + txns <- decCBOR + pure $ BlockRaw header txns + where + blockSize = 1 + fromIntegral (numSegComponents @era) + +instance + forall h era. + ( EraSegWits era + , DecCBOR h + , DecCBOR (TxSeq era) + ) => + DecCBOR (Block h era) + where + decCBOR = do + mb <- decodeMemoized (decCBOR @(BlockRaw h era)) + let (Memo (BlockRaw h txSeq) bs) = mb + pure $ Block' h txSeq (BSL.fromStrict (SBS.fromShort bs)) + bheader :: Block h era -> h From 369e40f2d6bac78871f63179819c9f6a2479cc7b Mon Sep 17 00:00:00 2001 From: teodanciu Date: Mon, 27 Jan 2025 13:41:56 +0000 Subject: [PATCH 15/32] [shelley] - LaxBlock --- .../test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs index db07bfb0340..744e9707983 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs @@ -30,6 +30,13 @@ import Data.Typeable (Typeable) newtype LaxBlock h era = LaxBlock (Block h era) deriving (ToCBOR) +deriving newtype instance + ( EraSegWits era + , DecCBOR (TxSeq era) + , DecCBOR h + ) => + DecCBOR (LaxBlock h era) + blockDecoder :: ( EraTx era , TxSeq era ~ ShelleyTxSeq era From 47bdb131e1ad766e67dadea608a1b098a43363cf Mon Sep 17 00:00:00 2001 From: teodanciu Date: Tue, 28 Jan 2025 15:30:53 +0000 Subject: [PATCH 16/32] [allegra] - AllegraTxBody --- eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody/Internal.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody/Internal.hs index fdf9a3cecff..7c107097e7f 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody/Internal.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody/Internal.hs @@ -210,7 +210,7 @@ emptyAllegraTxBodyRaw = -- Wrap it all up in a newtype, hiding the insides with a pattern construtor. newtype AllegraTxBody e = TxBodyConstr (MemoBytes (AllegraTxBodyRaw () e)) - deriving newtype (SafeToHash, ToCBOR) + deriving newtype (SafeToHash, ToCBOR, DecCBOR) instance Memoized (AllegraTxBody era) where type RawType (AllegraTxBody era) = AllegraTxBodyRaw () era From 43e348a841efd032f13c0b5ba2cf92e2180685cc Mon Sep 17 00:00:00 2001 From: teodanciu Date: Tue, 28 Jan 2025 15:38:34 +0000 Subject: [PATCH 17/32] [allegra] - AllegraTxAuxData --- .../src/Cardano/Ledger/Allegra/TxAuxData.hs | 26 ++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs index b887b9c84c9..28ecc8f40b7 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs @@ -122,7 +122,7 @@ instance NFData (AllegraTxAuxDataRaw era) newtype AllegraTxAuxData era = AuxiliaryDataWithBytes (MemoBytes (AllegraTxAuxDataRaw era)) deriving (Generic) - deriving newtype (Eq, ToCBOR, SafeToHash) + deriving newtype (Eq, ToCBOR, SafeToHash, DecCBOR) instance Memoized (AllegraTxAuxData era) where type RawType (AllegraTxAuxData era) = AllegraTxAuxDataRaw era @@ -187,6 +187,30 @@ instance Era era => DecCBOR (Annotator (AllegraTxAuxDataRaw era)) where <*! D (sequence <$> decCBOR) ) +instance Era era => DecCBOR (AllegraTxAuxDataRaw era) where + decCBOR = + peekTokenType >>= \case + TypeMapLen -> decodeFromMap + TypeMapLen64 -> decodeFromMap + TypeMapLenIndef -> decodeFromMap + TypeListLen -> decodeFromList + TypeListLen64 -> decodeFromList + TypeListLenIndef -> decodeFromList + _ -> error "Failed to decode AuxiliaryData" + where + decodeFromMap = + decode + ( Emit AllegraTxAuxDataRaw + Date: Tue, 28 Jan 2025 15:48:36 +0000 Subject: [PATCH 18/32] [mary] - MarryTxBody --- eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs index acfda9ab446..10280fe47c1 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody/Internal.hs @@ -148,6 +148,8 @@ deriving via instance MaryEraTxBody era => DecCBOR (Annotator (MaryTxBody era)) +deriving newtype instance MaryEraTxBody era => DecCBOR (MaryTxBody era) + type instance MemoHashIndex (MaryTxBodyRaw era) = EraIndependentTxBody instance Era era => HashAnnotated (MaryTxBody era) EraIndependentTxBody where From 0ac653af47013ed06d0abfbf1d01c8eb8399c18b Mon Sep 17 00:00:00 2001 From: teodanciu Date: Tue, 28 Jan 2025 15:56:30 +0000 Subject: [PATCH 19/32] [alonzo] - AlonzoTxBody --- eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs index e28af0b94cb..7417a22ad91 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody/Internal.hs @@ -401,6 +401,10 @@ deriving via (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => DecCBOR (Annotator (AlonzoTxBody era)) +deriving newtype instance + (Era era, DecCBOR (TxOut era), DecCBOR (TxCert era), DecCBOR (PParamsUpdate era)) => + DecCBOR (AlonzoTxBody era) + pattern AlonzoTxBody :: forall era. (EraTxOut era, EraTxCert era) => From 076fbdd61f6f34bd74e841b61cd56a80856381b1 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Tue, 28 Jan 2025 16:19:53 +0000 Subject: [PATCH 20/32] [alonzo] - AlonzoScript --- .../alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs index dbf9305634e..933262dc313 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs @@ -610,6 +610,18 @@ instance AlonzoEraScript era => DecCBOR (Annotator (AlonzoScript era)) where {-# INLINE decodeScript #-} {-# INLINE decCBOR #-} +instance AlonzoEraScript era => DecCBOR (AlonzoScript era) where + decCBOR = decode (Summands "AlonzoScript" decodeScript) + where + decodeScript = \case + 0 -> SumD TimelockScript decodePlutus SPlutusV1 + 2 -> decodePlutus SPlutusV2 + 3 -> decodePlutus SPlutusV3 + n -> Invalid n + decodePlutus slang = + SumD PlutusScript Date: Wed, 29 Jan 2025 09:26:07 +0000 Subject: [PATCH 21/32] [alonzo] - AlonzoTxAuxData --- .../src/Cardano/Ledger/Alonzo/TxAuxData.hs | 74 ++++++++++++++----- 1 file changed, 56 insertions(+), 18 deletions(-) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs index 3df8fcba175..5f2d482f918 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs @@ -59,6 +59,7 @@ import Cardano.Ledger.BaseTypes (ProtVer) import Cardano.Ledger.Binary ( Annotator (..), DecCBOR (..), + Decoder, EncCBOR (..), ToCBOR, TokenType (..), @@ -183,16 +184,10 @@ getAlonzoTxAuxDataScripts AlonzoTxAuxData {atadTimelock = timelocks, atadPlutus instance Era era => DecCBOR (Annotator (AlonzoTxAuxDataRaw era)) where decCBOR = - peekTokenType >>= \case - TypeMapLen -> decodeShelley - TypeMapLen64 -> decodeShelley - TypeMapLenIndef -> decodeShelley - TypeListLen -> decodeShelleyMA - TypeListLen64 -> decodeShelleyMA - TypeListLenIndef -> decodeShelleyMA - TypeTag -> decodeAlonzo - TypeTag64 -> decodeAlonzo - _ -> fail "Failed to decode AlonzoTxAuxData" + decodeTxAuxDataByTokenType @(Annotator (AlonzoTxAuxDataRaw era)) + decodeShelley + decodeShelleyMA + decodeAlonzo where decodeShelley = decode @@ -214,13 +209,6 @@ instance Era era => DecCBOR (Annotator (AlonzoTxAuxDataRaw era)) where TagD 259 $ SparseKeyed "AlonzoTxAuxData" (pure emptyAuxData) auxDataField [] - addPlutusScripts lang scripts ad = - case NE.nonEmpty scripts of - Nothing -> ad - Just neScripts -> - -- Avoid leaks by deepseq, since non empty list is lazy. - neScripts `deepseq` ad {atadrPlutus = Map.insert lang neScripts $ atadrPlutus ad} - auxDataField :: Word -> Field (Annotator (AlonzoTxAuxDataRaw era)) auxDataField 0 = fieldA (\x ad -> ad {atadrMetadata = x}) From auxDataField 1 = @@ -232,6 +220,56 @@ instance Era era => DecCBOR (Annotator (AlonzoTxAuxDataRaw era)) where auxDataField 4 = fieldA (addPlutusScripts PlutusV3) (D (guardPlutus PlutusV3 >> decCBOR)) auxDataField n = field (\_ t -> t) (Invalid n) +instance Era era => DecCBOR (AlonzoTxAuxDataRaw era) where + decCBOR = + decodeTxAuxDataByTokenType @(AlonzoTxAuxDataRaw era) + decodeShelley + decodeShelleyMA + decodeAlonzo + where + decodeShelley = + decode + (Emit AlonzoTxAuxDataRaw Field (AlonzoTxAuxDataRaw era) + auxDataField 0 = field (\x ad -> ad {atadrMetadata = x}) From + auxDataField 1 = + field + (\x ad -> ad {atadrTimelock = atadrTimelock ad <> x}) + (D (decodeStrictSeq decCBOR)) + auxDataField 2 = field (addPlutusScripts PlutusV1) (D (guardPlutus PlutusV1 >> decCBOR)) + auxDataField 3 = field (addPlutusScripts PlutusV2) (D (guardPlutus PlutusV2 >> decCBOR)) + auxDataField 4 = field (addPlutusScripts PlutusV3) (D (guardPlutus PlutusV3 >> decCBOR)) + auxDataField n = field (\_ t -> t) (Invalid n) + +decodeTxAuxDataByTokenType :: forall t s. Decoder s t -> Decoder s t -> Decoder s t -> Decoder s t +decodeTxAuxDataByTokenType decodeShelley decodeShelleyMA decodeAlonzo = + peekTokenType >>= \case + TypeMapLen -> decodeShelley + TypeMapLen64 -> decodeShelley + TypeMapLenIndef -> decodeShelley + TypeListLen -> decodeShelleyMA + TypeListLen64 -> decodeShelleyMA + TypeListLenIndef -> decodeShelleyMA + TypeTag -> decodeAlonzo + TypeTag64 -> decodeAlonzo + _ -> fail "Failed to decode AlonzoTxAuxData" + +addPlutusScripts :: Language -> [PlutusBinary] -> AlonzoTxAuxDataRaw era -> AlonzoTxAuxDataRaw era +addPlutusScripts lang scripts ad = + case NE.nonEmpty scripts of + Nothing -> ad + Just neScripts -> + -- Avoid leaks by deepseq, since non empty list is lazy. + neScripts `deepseq` ad {atadrPlutus = Map.insert lang neScripts $ atadrPlutus ad} + emptyAuxData :: AlonzoTxAuxDataRaw era emptyAuxData = AlonzoTxAuxDataRaw mempty mempty mempty @@ -240,7 +278,7 @@ emptyAuxData = AlonzoTxAuxDataRaw mempty mempty mempty newtype AlonzoTxAuxData era = AlonzoTxAuxDataConstr (MemoBytes (AlonzoTxAuxDataRaw era)) deriving (Generic) - deriving newtype (ToCBOR, SafeToHash) + deriving newtype (ToCBOR, SafeToHash, DecCBOR) instance Memoized (AlonzoTxAuxData era) where type RawType (AlonzoTxAuxData era) = AlonzoTxAuxDataRaw era From baf1e1c5151d3ba6ff8e53bb4fd130a2df05532a Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 29 Jan 2025 09:59:22 +0000 Subject: [PATCH 22/32] [alonzo] - TxDats --- eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs index 9f95857c0ed..335900378c8 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs @@ -336,12 +336,22 @@ instance Era era => DecCBOR (Annotator (TxDatsRaw era)) where (mapTraverseableDecoderA (decodeList decCBOR) (TxDatsRaw . Map.fromElems hashData)) {-# INLINE decCBOR #-} +instance Era era => DecCBOR (TxDatsRaw era) where + decCBOR = + ifDecoderVersionAtLeast + (natVersion @9) + ( allowTag setTag + >> TxDatsRaw . Map.fromElems hashData . NE.toList <$> decodeNonEmptyList decCBOR + ) + (TxDatsRaw . Map.fromElems hashData <$> decodeList decCBOR) + {-# INLINE decCBOR #-} + -- | Note that 'TxDats' are based on 'MemoBytes' since we must preserve -- the original bytes for the 'Cardano.Ledger.Alonzo.Tx.ScriptIntegrity'. -- Since the 'TxDats' exist outside of the transaction body, -- this is how we ensure that they are not manipulated. newtype TxDats era = TxDatsConstr (MemoBytes (TxDatsRaw era)) - deriving newtype (SafeToHash, ToCBOR, Eq, NoThunks, NFData) + deriving newtype (SafeToHash, ToCBOR, Eq, NoThunks, NFData, DecCBOR) deriving (Generic) instance Memoized (TxDats era) where From 110cbc37d9ed3ef141844c7be1c293cad652ec3a Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 29 Jan 2025 11:01:55 +0000 Subject: [PATCH 23/32] [alonzo] Redeemers --- .../impl/src/Cardano/Ledger/Alonzo/TxWits.hs | 36 ++++++++++++++++++- 1 file changed, 35 insertions(+), 1 deletion(-) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs index 335900378c8..9f9af467e39 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs @@ -171,7 +171,7 @@ instance Memoized (Redeemers era) where -- Since the 'Redeemers' exist outside of the transaction body, -- this is how we ensure that they are not manipulated. newtype Redeemers era = RedeemersConstr (MemoBytes (RedeemersRaw era)) - deriving newtype (Generic, ToCBOR, SafeToHash, Typeable) + deriving newtype (Generic, ToCBOR, SafeToHash, Typeable, DecCBOR) deriving newtype instance AlonzoEraScript era => Eq (Redeemers era) deriving newtype instance AlonzoEraScript era => NFData (Redeemers era) @@ -613,6 +613,40 @@ instance AlonzoEraScript era => DecCBOR (Annotator (RedeemersRaw era)) where {-# INLINE decodeElement #-} {-# INLINE decCBOR #-} +instance AlonzoEraScript era => DecCBOR (RedeemersRaw era) where + decCBOR = + ifDecoderVersionAtLeast + (natVersion @9) + ( peekTokenType >>= \case + TypeMapLenIndef -> decodeMapRedeemers + TypeMapLen -> decodeMapRedeemers + _ -> decodeListRedeemers + ) + (RedeemersRaw . Map.fromList <$> decodeList decodeElement) + where + decodeMapRedeemers :: Decoder s (RedeemersRaw era) + decodeMapRedeemers = + RedeemersRaw . Map.fromList . NE.toList <$> do + (_, xs) <- decodeListLikeWithCount decodeMapLenOrIndef (:) $ \_ -> do + ptr <- decCBOR + (annData, exUnits) <- decCBOR + pure (ptr, (annData, exUnits)) + case NE.nonEmpty xs of + Nothing -> fail "Expected redeemers map to be non-empty" + Just neList -> pure $ NE.reverse neList + decodeListRedeemers :: Decoder s (RedeemersRaw era) + decodeListRedeemers = + RedeemersRaw . Map.fromList . NE.toList + <$> decodeNonEmptyList decodeElement + decodeElement :: Decoder s (PlutusPurpose AsIx era, (Data era, ExUnits)) + decodeElement = do + decodeRecordNamed + "Redeemer" + (\(rdmrPtr, _) -> fromIntegral (listLen rdmrPtr) + 2) + $ (,) <$> decCBORGroup <*> ((,) <$> decCBOR <*> decCBOR) + {-# INLINE decodeElement #-} + {-# INLINE decCBOR #-} + -- | Encodes memoized bytes created upon construction. instance AlonzoEraScript era => EncCBOR (Redeemers era) From 1814495d26057830f44a87705920b4443ce6a33d Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 29 Jan 2025 14:24:14 +0000 Subject: [PATCH 24/32] [alonzo] - AlonzoTxWits --- .../impl/src/Cardano/Ledger/Alonzo/TxWits.hs | 63 +++++++++++++++++++ 1 file changed, 63 insertions(+) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs index 9f9af467e39..328e3f95653 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs @@ -723,6 +723,69 @@ instance pairDecoder = fmap (asHashedPair . fromNativeScript) <$> decCBOR {-# INLINE decCBOR #-} +instance + ( AlonzoEraScript era + , DecCBOR (NativeScript era) + ) => + DecCBOR (AlonzoTxWitsRaw era) + where + decCBOR = + decode $ + SparseKeyed + "AlonzoTxWits" + emptyTxWitness + txWitnessField + [] + where + txWitnessField :: Word -> Field (AlonzoTxWitsRaw era) + txWitnessField 0 = + field + (\x wits -> wits {atwrAddrTxWits = x}) + ( D $ + ifDecoderVersionAtLeast + (natVersion @9) + ( allowTag setTag + >> Set.fromList . NE.toList <$> decodeNonEmptyList decCBOR + ) + (Set.fromList <$> decodeList decCBOR) + ) + txWitnessField 1 = field addScripts (D nativeScriptsDecoder) + txWitnessField 2 = + field + (\x wits -> wits {atwrBootAddrTxWits = x}) + ( D $ + ifDecoderVersionAtLeast + (natVersion @9) + ( allowTag setTag + >> Set.fromList . NE.toList <$> decodeNonEmptyList decCBOR + ) + (Set.fromList <$> decodeList decCBOR) + ) + txWitnessField 3 = field addScripts (decodePlutus SPlutusV1) + txWitnessField 4 = field (\x wits -> wits {atwrDatsTxWits = x}) From + txWitnessField 5 = field (\x wits -> wits {atwrRdmrsTxWits = x}) From + txWitnessField 6 = field addScripts (decodePlutus SPlutusV2) + txWitnessField 7 = field addScripts (decodePlutus SPlutusV3) + txWitnessField n = field (\_ t -> t) (Invalid n) + + nativeScriptsDecoder :: Decoder s (Map ScriptHash (Script era)) + nativeScriptsDecoder = + ifDecoderVersionAtLeast + (natVersion @9) + ( allowTag setTag + >> Map.fromList . NE.toList <$> decodeNonEmptyList pairDecoder + ) + (Map.fromList <$> decodeList pairDecoder) + where + pairDecoder :: Decoder s (ScriptHash, Script era) + pairDecoder = asHashedPair @era . fromNativeScript <$> decCBOR + +deriving newtype instance + ( AlonzoEraScript era + , DecCBOR (NativeScript era) + ) => + DecCBOR (AlonzoTxWits era) + addScripts :: Map ScriptHash (Script era) -> AlonzoTxWitsRaw era -> From b1f56eeecbd3f8169ded67a54e2a4b29a107648b Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 29 Jan 2025 14:45:25 +0000 Subject: [PATCH 25/32] [alonzo] - AlonzoTx --- .../alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs index 8786c41e834..7b0976b15bc 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs @@ -449,6 +449,23 @@ instance ) {-# INLINE decCBOR #-} +instance + ( Typeable era + , DecCBOR (TxBody era) + , DecCBOR (TxWits era) + , DecCBOR (TxAuxData era) + ) => + DecCBOR (AlonzoTx era) + where + decCBOR = + decode $ + RecD AlonzoTx + decodeNullMaybe decCBOR) + {-# INLINE decCBOR #-} + alonzoEqTxRaw :: AlonzoEraTx era => Tx era -> Tx era -> Bool alonzoEqTxRaw tx1 tx2 = shelleyEqTxRaw tx1 tx2 && (tx1 ^. isValidTxL == tx2 ^. isValidTxL) From ec389061bc7d5277461347b32fdbf887c677ce3a Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 29 Jan 2025 14:48:14 +0000 Subject: [PATCH 26/32] [alonzo] - TranslationInstance --- .../Alonzo/Translation/TranslationInstance.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs index 129b86173ec..2ee2b3ebd42 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs @@ -35,6 +35,7 @@ import Cardano.Ledger.Binary.Coders ( decode, encode, (!>), + ( + DecCBOR (TranslationInstance era) + where + decCBOR = + decode $ + RecD TranslationInstance + Date: Wed, 29 Jan 2025 14:55:38 +0000 Subject: [PATCH 27/32] [babbage] - BabbageTxBody --- .../impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs index e6b0081fd6e..7ade3d21c87 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody/Internal.hs @@ -236,6 +236,14 @@ deriving instance newtype BabbageTxBody era = TxBodyConstr (MemoBytes (BabbageTxBodyRaw era)) deriving newtype (Generic, SafeToHash, ToCBOR) +deriving newtype instance + ( Era era + , DecCBOR (TxOut era) + , DecCBOR (TxCert era) + , DecCBOR (PParamsUpdate era) + ) => + DecCBOR (BabbageTxBody era) + instance Memoized (BabbageTxBody era) where type RawType (BabbageTxBody era) = BabbageTxBodyRaw era From 3ddc583ecb3d9e7d9aec8a5852edd2b88d2d131b Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 29 Jan 2025 15:01:27 +0000 Subject: [PATCH 28/32] [conway] - ConwayTxBody --- .../impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs index ed543cc42df..bf612496c90 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody/Internal.hs @@ -267,6 +267,14 @@ instance newtype ConwayTxBody era = TxBodyConstr (MemoBytes (ConwayTxBodyRaw era)) deriving (Generic, SafeToHash, ToCBOR) +deriving newtype instance + ( EraPParams era + , DecCBOR (TxOut era) + , ShelleyEraTxCert era + , TxCert era ~ ConwayTxCert era + ) => + DecCBOR (ConwayTxBody era) + deriving instance (EraPParams era, NoThunks (TxOut era)) => NoThunks (ConwayTxBody era) From ba73dacae97cda3b5d5ae414beddaff4dc2217fd Mon Sep 17 00:00:00 2001 From: teodanciu Date: Thu, 30 Jan 2025 15:02:35 +0000 Subject: [PATCH 29/32] [shelley] - ShelleyTxSeq --- eras/shelley/impl/CHANGELOG.md | 1 + .../src/Cardano/Ledger/Shelley/BlockChain.hs | 45 +++++++++++++++++-- .../impl/src/Cardano/Ledger/Shelley/Tx.hs | 1 + .../src/Cardano/Ledger/Shelley/Tx/Internal.hs | 28 ++++++++++++ 4 files changed, 71 insertions(+), 4 deletions(-) diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 1cdacacb267..8f81bbbf89a 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.16.0.0 +* Add `segWitTx` * Rename `segwitTx` to `segWitAnnTx` * Move `AccountState` to `Cardano.Ledger.State` * Deprecated `RewardAccounts` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs index 0724a4a1a02..bfc3397701c 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs @@ -39,11 +39,13 @@ import Cardano.Ledger.BaseTypes ( strictMaybeToMaybe, ) import Cardano.Ledger.Binary ( + Annotated (..), Annotator (..), DecCBOR (decCBOR), Decoder, EncCBOR (..), EncCBORGroup (..), + decodeAnnotated, encodeFoldableEncoder, encodeFoldableMapEncoder, encodePreEncoded, @@ -52,7 +54,7 @@ import Cardano.Ledger.Binary ( ) import Cardano.Ledger.Core import Cardano.Ledger.Shelley.Era (ShelleyEra) -import Cardano.Ledger.Shelley.Tx (ShelleyTx, segWitAnnTx) +import Cardano.Ledger.Shelley.Tx (ShelleyTx, segWitAnnTx, segWitTx) import Cardano.Ledger.Slot (SlotNo (..)) import Control.Monad (unless) import Data.ByteString (ByteString) @@ -188,14 +190,16 @@ bbHash (TxSeq' _ bodies wits md) = hashPart = Hash.hashToBytes . hashStrict . BSL.toStrict -- | Given a size and a mapping from indices to maybe metadata, --- return a sequence whose size is the size paramater and +-- return a sequence whose size is the size parameter and -- whose non-Nothing values correspond to the values in the mapping. constructMetadata :: - forall era. Int -> Map Int (Annotator (TxAuxData era)) -> Seq (Maybe (Annotator (TxAuxData era))) -constructMetadata n md = fmap (`Map.lookup` md) (Seq.fromList [0 .. n - 1]) +constructMetadata = indexLookupSeq + +indexLookupSeq :: Int -> Map Int a -> Seq (Maybe a) +indexLookupSeq n md = fmap (`Map.lookup` md) (Seq.fromList [0 .. n - 1]) -- | The parts of the Tx in Blocks that have to have DecCBOR(Annotator x) instances. -- These are exactly the parts that are SafeToHash. @@ -239,6 +243,39 @@ txSeqDecoder lax = do instance EraTx era => DecCBOR (Annotator (ShelleyTxSeq era)) where decCBOR = txSeqDecoder False +instance + ( EraTx era + , DecCBOR (TxBody era) + , DecCBOR (TxWits era) + , DecCBOR (TxAuxData era) + ) => + DecCBOR (ShelleyTxSeq era) + where + decCBOR = do + Annotated bodies bodiesBs <- decodeAnnotated decCBOR + Annotated wits witsBs <- decodeAnnotated decCBOR + Annotated auxDataMap auxDataBs <- decodeAnnotated decCBOR + let b = length bodies + let inRange x = (0 <= x) && (x <= (b - 1)) + unless + (all inRange (Map.keysSet auxDataMap)) + (fail ("Some Auxiliarydata index is not in the range: 0 .. " ++ show (b - 1))) + let auxData = indexLookupSeq b auxDataMap + let w = length wits + unless + (b == w) + ( fail $ + "different number of transaction bodies (" + <> show b + <> ") and witness sets (" + <> show w + <> ")" + ) + let txs = + StrictSeq.forceToStrict $ + Seq.zipWith3 segWitTx bodies wits auxData + pure $ TxSeq' txs bodiesBs witsBs auxDataBs + slotToNonce :: SlotNo -> Nonce slotToNonce (SlotNo s) = mkNonceFromNumber s diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs index 13f821da55e..37d5514969f 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs @@ -13,6 +13,7 @@ module Cardano.Ledger.Shelley.Tx ( sizeShelleyTxF, wireSizeShelleyTxF, segWitAnnTx, + segWitTx, mkBasicShelleyTx, shelleyMinFeeTx, witsFromTxWitnesses, diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs index 0b1676edf8d..0d52b17aacf 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx/Internal.hs @@ -40,6 +40,7 @@ module Cardano.Ledger.Shelley.Tx.Internal ( sizeShelleyTxF, wireSizeShelleyTxF, segWitAnnTx, + segWitTx, mkBasicShelleyTx, shelleyMinFeeTx, witsFromTxWitnesses, @@ -398,6 +399,33 @@ segWitAnnTx (maybeToStrictMaybe metadata) fullBytes +segWitTx :: + forall era. + EraTx era => + TxBody era -> + TxWits era -> + Maybe (TxAuxData era) -> + ShelleyTx era +segWitTx + body' + witnessSet + metadata = + let + wrappedMetadataBytes = case metadata of + Nothing -> Plain.serialize Plain.encodeNull + Just b -> Plain.serialize b + fullBytes = + Plain.serialize (Plain.encodeListLen 3) + <> Plain.serialize body' + <> Plain.serialize witnessSet + <> wrappedMetadataBytes + in + unsafeConstructTxWithBytes + body' + witnessSet + (maybeToStrictMaybe metadata) + fullBytes + -- ======================================== -- | Minimum fee calculation From 30282f897d20b5ed1a0a803599b36197d4067d55 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Thu, 30 Jan 2025 19:50:07 +0000 Subject: [PATCH 30/32] [wip] - add non-annotator cbor checks in golden Encoding tests --- .../Shelley/Serialisation/Golden/Encoding.hs | 117 ++++++++++-------- 1 file changed, 68 insertions(+), 49 deletions(-) diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs index 9df716f2f2f..3252404acce 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs @@ -457,6 +457,16 @@ tests = <> S vk -- vkey <> T (testKey1SigToken @C) -- signature ) + , case mkWitnessVKey (testTxbHash @C) testKey1 of + w@(WitVKey vk _sig) -> + checkEncodingCBORAnnotated + shelleyProtVer + "vkey_witnesses" + w -- Transaction _witnessVKeySet element + ( T (TkListLen 2) + <> S vk -- vkey + <> T (testKey1SigToken @C) -- signature + ) , checkEncoding shelleyProtVer (fromPlainEncoding . toCBOR) @@ -1045,55 +1055,64 @@ tests = & witsTxL @C .~ (mkBasicTxWits @C & addrTxWitsL .~ ws & scriptTxWitsL .~ ss) & auxDataTxL @C .~ SJust tx5MD txns = ShelleyTxSeq $ StrictSeq.fromList [tx1, tx2, tx3, tx4, tx5] - in checkEncodingCBORAnnotated - shelleyProtVer - "rich_block" - (Block @C bh txns) - ( (T $ TkListLen 4) - -- header - <> S bh - -- bodies - <> T (TkListLen 5) - <> S txb1 - <> S txb2 - <> S txb3 - <> S txb4 - <> S txb5 - -- witnesses - <> T (TkListLen 5) - -- tx 1, one key - <> T (TkMapLen 1 . TkWord 0) - <> T (TkListLen 1) - <> S w1 - -- tx 2, two keys - <> T (TkMapLen 1 . TkWord 0) - <> T (TkListLen 2) - <> S w2 - <> S w1 - -- tx 3, one script - <> T (TkMapLen 1 . TkWord 1) - <> T (TkListLen 1) - <> S testScript - -- tx 4, two scripts - <> T (TkMapLen 1 . TkWord 1) - <> T (TkListLen 2) - <> S testScript - <> S testScript2 - -- tx 5, two keys and two scripts - <> T (TkMapLen 2) - <> T (TkWord 0) - <> T (TkListLen 2) - <> S w2 - <> S w1 - <> T (TkWord 1) - <> T (TkListLen 2) - <> S testScript - <> S testScript2 - -- metadata - <> T (TkMapLen 1) - <> T (TkInt 4) - <> S tx5MD - ) + xxx = + (T $ TkListLen 4) + -- header + <> S bh + -- bodies + <> T (TkListLen 5) + <> S txb1 + <> S txb2 + <> S txb3 + <> S txb4 + <> S txb5 + -- witnesses + <> T (TkListLen 5) + -- tx 1, one key + <> T (TkMapLen 1 . TkWord 0) + <> T (TkListLen 1) + <> S w1 + -- tx 2, two keys + <> T (TkMapLen 1 . TkWord 0) + <> T (TkListLen 2) + <> S w2 + <> S w1 + -- tx 3, one script + <> T (TkMapLen 1 . TkWord 1) + <> T (TkListLen 1) + <> S testScript + -- tx 4, two scripts + <> T (TkMapLen 1 . TkWord 1) + <> T (TkListLen 2) + <> S testScript + <> S testScript2 + -- tx 5, two keys and two scripts + <> T (TkMapLen 2) + <> T (TkWord 0) + <> T (TkListLen 2) + <> S w2 + <> S w1 + <> T (TkWord 1) + <> T (TkListLen 2) + <> S testScript + <> S testScript2 + -- metadata + <> T (TkMapLen 1) + <> T (TkInt 4) + <> S tx5MD + in testGroup + "Block" + [ checkEncodingCBORAnnotated + shelleyProtVer + "rich_block" + (Block @C bh txns) + xxx + , checkEncodingCBOR + shelleyProtVer + "rich_block - non-annotated" + (Block @C bh txns) + xxx + ] , let actual = Plain.serialize' $ Ex.sleNewEpochState Ex.ledgerExamplesShelley expected = either error id $ B16.decode expectedHex From 50817c5c9ff0b7d067dcc5448ebd089630ec1f56 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Thu, 30 Jan 2025 20:37:16 +0000 Subject: [PATCH 31/32] [alonzo] - AlonzoTxSeq --- .../Cardano/Ledger/Alonzo/TxSeq/Internal.hs | 65 ++++++++++++++++++- eras/shelley/impl/CHANGELOG.md | 1 + .../src/Cardano/Ledger/Shelley/BlockChain.hs | 1 + 3 files changed, 65 insertions(+), 2 deletions(-) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq/Internal.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq/Internal.hs index a2ddb84f4dd..f9c43ad7792 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq/Internal.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq/Internal.hs @@ -32,9 +32,11 @@ import qualified Cardano.Crypto.Hash as Hash import Cardano.Ledger.Alonzo.Era import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..), IsValid (..), alonzoSegwitTx) import Cardano.Ledger.Binary ( + Annotated (..), Annotator, DecCBOR (..), EncCBORGroup (..), + decodeAnnotated, encCBOR, encodeFoldableEncoder, encodeFoldableMapEncoder, @@ -44,14 +46,14 @@ import Cardano.Ledger.Binary ( withSlice, ) import Cardano.Ledger.Core -import Cardano.Ledger.Shelley.BlockChain (constructMetadata) +import Cardano.Ledger.Shelley.BlockChain (constructMetadata, indexLookupSeq) import Control.Monad (unless) import Data.ByteString (ByteString) import Data.ByteString.Builder (shortByteString, toLazyByteString) import qualified Data.ByteString.Lazy as BSL import Data.Coerce (coerce) import qualified Data.Map.Strict as Map -import Data.Maybe.Strict (strictMaybeToMaybe) +import Data.Maybe.Strict (maybeToStrictMaybe, strictMaybeToMaybe) import Data.Proxy (Proxy (..)) import qualified Data.Sequence as Seq import Data.Sequence.Strict (StrictSeq) @@ -230,6 +232,65 @@ instance AlonzoEraTx era => DecCBOR (Annotator (AlonzoTxSeq era)) where <*> auxDataAnn <*> isValAnn +instance + ( AlonzoEraTx era + , DecCBOR (TxBody era) + , DecCBOR (TxWits era) + , DecCBOR (TxAuxData era) + ) => + DecCBOR (AlonzoTxSeq era) + where + decCBOR = do + Annotated bodies bodiesBs <- decodeAnnotated decCBOR + Annotated wits witsBs <- decodeAnnotated decCBOR + Annotated auxDataMap auxDataBs <- decodeAnnotated decCBOR + let b = length bodies + inRange x = (0 <= x) && (x <= (b - 1)) + w = length wits + unless + (all inRange (Map.keysSet auxDataMap)) + ( fail + ( "Some Auxiliarydata index is not in the range: 0 .. " + ++ show (b - 1) + ) + ) + let auxData = maybeToStrictMaybe <$> indexLookupSeq b auxDataMap + Annotated isValidIdxs isValidBs <- decodeAnnotated decCBOR + let vs = alignedValidFlags b isValidIdxs + unless + (b == w) + ( fail $ + "different number of transaction bodies (" + <> show b + <> ") and witness sets (" + <> show w + <> ")" + ) + unless + (all inRange isValidIdxs) + ( fail + ( "Some IsValid index is not in the range: 0 .. " + ++ show (b - 1) + ++ ", " + ++ show isValidIdxs + ) + ) + let mkTx body wt isValid ad = + mkBasicTx body + & witsTxL .~ wt + & auxDataTxL .~ ad + & isValidTxL .~ isValid + let txs = + StrictSeq.forceToStrict $ + Seq.zipWith4 mkTx bodies wits vs auxData + pure $ + AlonzoTxSeqRaw + txs + bodiesBs + witsBs + auxDataBs + isValidBs + -------------------------------------------------------------------------------- -- Internal utility functions -------------------------------------------------------------------------------- diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 8f81bbbf89a..f686ddb4855 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.16.0.0 +* Add `indexLookupSeq` * Add `segWitTx` * Rename `segwitTx` to `segWitAnnTx` * Move `AccountState` to `Cardano.Ledger.State` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs index bfc3397701c..667cf9dd4fd 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs @@ -19,6 +19,7 @@ module Cardano.Ledger.Shelley.BlockChain ( ShelleyTxSeq (ShelleyTxSeq, txSeqTxns', TxSeq'), constructMetadata, + indexLookupSeq, txSeqTxns, bbHash, bBodySize, From 73de5861a762c864c2b64fdb7daa5045e39a1f5c Mon Sep 17 00:00:00 2001 From: teodanciu Date: Mon, 3 Feb 2025 15:19:05 +0000 Subject: [PATCH 32/32] Add cbor `RoundTrip` tests for blocks for each era --- .../cardano-protocol-tpraos.cabal | 11 +++- libs/cardano-protocol-tpraos/test/Main.hs | 2 + .../Test/Cardano/Protocol/Binary/RoundTrip.hs | 51 +++++++++++++++++++ 3 files changed, 62 insertions(+), 2 deletions(-) create mode 100644 libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/RoundTrip.hs diff --git a/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal b/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal index 78fb184f812..8af63bcb61c 100644 --- a/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal +++ b/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal @@ -95,7 +95,9 @@ test-suite tests type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test - other-modules: Test.Cardano.Protocol.Binary.CddlSpec + other-modules: + Test.Cardano.Protocol.Binary.CddlSpec + Test.Cardano.Protocol.Binary.RoundTrip default-language: Haskell2010 ghc-options: -Wall @@ -112,7 +114,12 @@ test-suite tests build-depends: base, bytestring, + cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib}, + cardano-ledger-allegra:{cardano-ledger-allegra, testlib}, + cardano-ledger-babbage:{cardano-ledger-babbage,testlib}, cardano-ledger-binary:{cardano-ledger-binary, testlib}, + cardano-ledger-mary:{cardano-ledger-mary, testlib}, + cardano-ledger-conway:{cardano-ledger-conway, testlib}, cardano-ledger-core:{cardano-ledger-core, testlib}, cardano-ledger-shelley:{cardano-ledger-shelley, testlib}, - cardano-protocol-tpraos, + cardano-protocol-tpraos:{cardano-protocol-tpraos, testlib}, diff --git a/libs/cardano-protocol-tpraos/test/Main.hs b/libs/cardano-protocol-tpraos/test/Main.hs index dd17f62b0cc..148409931bb 100644 --- a/libs/cardano-protocol-tpraos/test/Main.hs +++ b/libs/cardano-protocol-tpraos/test/Main.hs @@ -2,9 +2,11 @@ module Main where import Test.Cardano.Ledger.Common import qualified Test.Cardano.Protocol.Binary.CddlSpec as Cddl +import qualified Test.Cardano.Protocol.Binary.RoundTrip as RoundTrip main :: IO () main = ledgerTestMain $ describe "TPraos" $ do Cddl.spec + RoundTrip.spec diff --git a/libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/RoundTrip.hs b/libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/RoundTrip.hs new file mode 100644 index 00000000000..bef912e0d1b --- /dev/null +++ b/libs/cardano-protocol-tpraos/test/Test/Cardano/Protocol/Binary/RoundTrip.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Protocol.Binary.RoundTrip (spec) where + +import Cardano.Ledger.Allegra (AllegraEra) +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Babbage (BabbageEra) +import Cardano.Ledger.Binary +import Cardano.Ledger.Block (Block) +import Cardano.Ledger.Conway (ConwayEra) +import Cardano.Ledger.Core +import Cardano.Ledger.Mary (MaryEra) +import Cardano.Ledger.Shelley (ShelleyEra) +import Cardano.Protocol.Crypto (StandardCrypto) +import Cardano.Protocol.TPraos.BHeader (BHeader) +import Data.Proxy (Proxy (..)) +import Data.Typeable +import Test.Cardano.Ledger.Alonzo.Arbitrary () +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Conway.Arbitrary () +import Test.Cardano.Ledger.Core.Binary.RoundTrip +import Test.Cardano.Protocol.TPraos.Arbitrary () + +spec :: Spec +spec = do + describe "RoundTrip" $ do + roundTripBlock @ShelleyEra + roundTripBlock @AllegraEra + roundTripBlock @MaryEra + roundTripBlock @AlonzoEra + roundTripBlock @BabbageEra + roundTripBlock @ConwayEra + +roundTripBlock :: + forall era. + ( EraSegWits era + , Arbitrary (Tx era) + ) => + Spec +roundTripBlock = + prop (show (typeRep $ Proxy @(Block (BHeader StandardCrypto) era))) $ + withMaxSuccess 3 $ + roundTripAnnEraExpectation @era @(Block (BHeader StandardCrypto) era)