From 6f1d005490d7662cf07ad35c2272ef44bd96a462 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Thu, 8 Jul 2021 14:24:39 +0200 Subject: [PATCH 1/7] Move Cardano.Ledger.Tx to Shelley.Spec.Ledger.Tx The theme behind this change is that consensus (and the node, and components above this) will regard an Alonzo Tx to be the full Tx, including the `IsValidating` tag. Where previously we exposed the unvarnished `Tx` and kept the `TxInBlock` as a ledger-internal detail, we will now be doing the opposite - exposing the full `TxInBlock`. --- alonzo/impl/src/Cardano/Ledger/Alonzo.hs | 2 +- .../src/Cardano/Ledger/Alonzo/Translation.hs | 2 +- .../Cardano/Ledger/Alonzo/AlonzoEraGen.hs | 2 +- .../Ledger/Alonzo/Serialisation/Tripping.hs | 2 +- cardano-ledger-core/cardano-ledger-core.cabal | 1 - .../src/Cardano/Ledger/Core.hs | 4 +- cardano-ledger-core/src/Cardano/Ledger/Tx.hs | 217 ------------------ .../src/Cardano/Ledger/Tx.hs-boot | 9 - .../Ledger/Examples/TwoPhaseValidation.hs | 2 +- .../src/Shelley/Spec/Ledger/API/Wallet.hs | 3 +- .../src/Shelley/Spec/Ledger/Tx.hs | 194 ++++++++++++++-- .../src/Test/Shelley/Spec/Ledger/Shrinkers.hs | 2 +- .../test/Test/Shelley/Spec/Ledger/Fees.hs | 4 +- 13 files changed, 193 insertions(+), 251 deletions(-) delete mode 100644 cardano-ledger-core/src/Cardano/Ledger/Tx.hs delete mode 100644 cardano-ledger-core/src/Cardano/Ledger/Tx.hs-boot diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo.hs index 2130de36b3..c3ef90897c 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo.hs @@ -64,7 +64,6 @@ import Cardano.Ledger.Shelley.Constraints ) import Cardano.Ledger.ShelleyMA.Rules.Utxo (consumed) import Cardano.Ledger.ShelleyMA.Timelocks (validateTimelock) -import Cardano.Ledger.Tx (Tx (Tx)) import Cardano.Ledger.Val (Val (inject), coin, (<->)) import Control.Arrow (left) import Control.Monad.Except (liftEither, runExcept) @@ -105,6 +104,7 @@ import qualified Shelley.Spec.Ledger.STS.Snap as Shelley import qualified Shelley.Spec.Ledger.STS.Tick as Shelley import qualified Shelley.Spec.Ledger.STS.Upec as Shelley import Shelley.Spec.Ledger.STS.Utxow (UtxowPredicateFailure (UtxoFailure)) +import Shelley.Spec.Ledger.Tx (Tx (Tx)) import qualified Shelley.Spec.Ledger.Tx as Shelley import Shelley.Spec.Ledger.UTxO (balance) diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs index 736a6e3245..fb93e32c89 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs @@ -38,7 +38,6 @@ import Cardano.Ledger.Era ) import qualified Cardano.Ledger.Era as Era import Cardano.Ledger.Mary (MaryEra) -import qualified Cardano.Ledger.Tx as LTX import Control.Monad.Except (Except, throwError) import Data.Coders import Data.Text (Text) @@ -50,6 +49,7 @@ import Shelley.Spec.Ledger.API ) import qualified Shelley.Spec.Ledger.API as API import qualified Shelley.Spec.Ledger.PParams as Shelley +import qualified Shelley.Spec.Ledger.Tx as LTX import qualified Shelley.Spec.Ledger.TxBody as Shelley -------------------------------------------------------------------------------- diff --git a/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs b/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs index 2c642daed8..083107044e 100644 --- a/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs +++ b/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs @@ -54,7 +54,6 @@ import Cardano.Ledger.Mary (MaryEra) import Cardano.Ledger.Mary.Value (policies) import Cardano.Ledger.ShelleyMA.AuxiliaryData as Mary (pattern AuxiliaryData) import Cardano.Ledger.ShelleyMA.Timelocks (Timelock (..)) -import Cardano.Ledger.Tx (Tx (Tx)) import Cardano.Ledger.Val (adaOnly, (<+>), (<×>)) import Cardano.Slotting.Slot (SlotNo (..)) import Control.Iterate.SetAlgebra (eval, (◁)) @@ -74,6 +73,7 @@ import Plutus.V1.Ledger.Api (defaultCostModelParams) import qualified PlutusTx as P (Data (..)) import qualified PlutusTx as Plutus import Shelley.Spec.Ledger.PParams (Update) +import Shelley.Spec.Ledger.Tx (Tx (Tx)) import Shelley.Spec.Ledger.TxBody (DCert, TxIn, Wdrl) import Shelley.Spec.Ledger.UTxO (UTxO (..)) import Test.Cardano.Ledger.AllegraEraGen (genValidityInterval) diff --git a/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Serialisation/Tripping.hs b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Serialisation/Tripping.hs index ecffb8e887..c9e72ecb83 100644 --- a/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Serialisation/Tripping.hs +++ b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Serialisation/Tripping.hs @@ -16,13 +16,13 @@ import Cardano.Ledger.Alonzo.Scripts (Script) import Cardano.Ledger.Alonzo.Tx (CostModel) import Cardano.Ledger.Alonzo.TxBody (TxBody) import Cardano.Ledger.Alonzo.TxWitness -import qualified Cardano.Ledger.Tx as LTX import qualified Data.ByteString as BS (ByteString) import qualified Data.ByteString.Base16.Lazy as Base16 import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Plutus.V1.Ledger.Api as Plutus import Shelley.Spec.Ledger.BlockChain (Block) import Shelley.Spec.Ledger.Metadata (Metadata) +import qualified Shelley.Spec.Ledger.Tx as LTX import Test.Cardano.Ledger.Alonzo.Serialisation.Generators () import Test.Cardano.Ledger.ShelleyMA.Serialisation.Coders (roundTrip, roundTripAnn) import Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators () diff --git a/cardano-ledger-core/cardano-ledger-core.cabal b/cardano-ledger-core/cardano-ledger-core.cabal index 56d27c613c..a737519f85 100644 --- a/cardano-ledger-core/cardano-ledger-core.cabal +++ b/cardano-ledger-core/cardano-ledger-core.cabal @@ -55,7 +55,6 @@ library Cardano.Ledger.SafeHash Cardano.Ledger.Serialization Cardano.Ledger.Slot - Cardano.Ledger.Tx Cardano.Ledger.Val build-depends: diff --git a/cardano-ledger-core/src/Cardano/Ledger/Core.hs b/cardano-ledger-core/src/Cardano/Ledger/Core.hs index dc1b7545ac..3d055ea232 100644 --- a/cardano-ledger-core/src/Cardano/Ledger/Core.hs +++ b/cardano-ledger-core/src/Cardano/Ledger/Core.hs @@ -40,12 +40,14 @@ module Cardano.Ledger.Core where import Cardano.Binary (Annotator, FromCBOR (..), ToCBOR (..)) -import {-# SOURCE #-} Cardano.Ledger.Tx (Tx) import Data.Kind (Type) import Data.Typeable (Typeable) import GHC.TypeLits (Symbol) import NoThunks.Class (NoThunks) +-- | A transaction. +type family Tx era :: Type + -- | A transaction output. type family TxOut era :: Type diff --git a/cardano-ledger-core/src/Cardano/Ledger/Tx.hs b/cardano-ledger-core/src/Cardano/Ledger/Tx.hs deleted file mode 100644 index 40c48f7792..0000000000 --- a/cardano-ledger-core/src/Cardano/Ledger/Tx.hs +++ /dev/null @@ -1,217 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Era-generic transactions. --- --- We make the assertion that the transaction format is independent between --- eras, varying only in its components. Thus a transaction consists of a body, --- witnesses, and any auxiliary data. -module Cardano.Ledger.Tx - ( Tx (Tx, body, wits, auxiliaryData), - unsafeConstructTxWithBytes, - ) -where - -import Cardano.Binary - ( Annotator (Annotator), - FromCBOR (fromCBOR), - ToCBOR (toCBOR), - ) -import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Era) -import Cardano.Ledger.SafeHash (SafeToHash) -import qualified Data.ByteString.Short as SBS -import Data.Coders - ( Decode (Ann, D, From, RecD), - Density (Dense), - Encode (E, Rec, To), - Wrapped (Closed), - decode, - decodeNullMaybe, - encodeNullMaybe, - (!>), - (<*!), - ) -import Data.Maybe.Strict (StrictMaybe, maybeToStrictMaybe, strictMaybeToMaybe) -import Data.MemoBytes (Mem, MemoBytes (Memo), memoBytes) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import GHC.Records (HasField (..)) -import NoThunks.Class (NoThunks) - -data TxRaw era = TxRaw - { _body :: !(Core.TxBody era), - _wits :: !(Core.Witnesses era), - _auxiliaryData :: !(StrictMaybe (Core.AuxiliaryData era)) - } - deriving (Generic, Typeable) - -deriving instance - ( Era era, - Eq (Core.AuxiliaryData era), - Eq (Core.TxBody era), - Eq (Core.Witnesses era) - ) => - Eq (TxRaw era) - -deriving instance - ( Era era, - Show (Core.AuxiliaryData era), - Show (Core.TxBody era), - Show (Core.Witnesses era) - ) => - Show (TxRaw era) - -instance - ( Era era, - NoThunks (Core.AuxiliaryData era), - NoThunks (Core.TxBody era), - NoThunks (Core.Witnesses era) - ) => - NoThunks (TxRaw era) - -newtype Tx era = TxConstr (MemoBytes (TxRaw era)) - deriving newtype (SafeToHash, ToCBOR) - -deriving newtype instance - ( Era era, - Eq (Core.AuxiliaryData era), - Eq (Core.TxBody era), - Eq (Core.Witnesses era) - ) => - Eq (Tx era) - -deriving newtype instance - ( Era era, - Show (Core.AuxiliaryData era), - Show (Core.TxBody era), - Show (Core.Witnesses era) - ) => - Show (Tx era) - -deriving newtype instance - ( Era era, - NoThunks (Core.AuxiliaryData era), - NoThunks (Core.TxBody era), - NoThunks (Core.Witnesses era) - ) => - NoThunks (Tx era) - -pattern Tx :: - ( Era era, - ToCBOR (Core.AuxiliaryData era), - ToCBOR (Core.TxBody era), - ToCBOR (Core.Witnesses era) - ) => - Core.TxBody era -> - Core.Witnesses era -> - StrictMaybe (Core.AuxiliaryData era) -> - Tx era -pattern Tx {body, wits, auxiliaryData} <- - TxConstr - ( Memo - TxRaw - { _body = body, - _wits = wits, - _auxiliaryData = auxiliaryData - } - _ - ) - where - Tx b w a = TxConstr $ memoBytes (encodeTxRaw $ TxRaw b w a) - -{-# COMPLETE Tx #-} - --------------------------------------------------------------------------------- --- Field accessors --------------------------------------------------------------------------------- - -instance - aux ~ Core.AuxiliaryData era => - HasField "auxiliaryData" (Tx era) (StrictMaybe aux) - where - getField (TxConstr (Memo (TxRaw _ _ a) _)) = a - -instance (body ~ Core.TxBody era) => HasField "body" (Tx era) body where - getField (TxConstr (Memo (TxRaw b _ _) _)) = b - -instance - (wits ~ Core.Witnesses era) => - HasField "wits" (Tx era) wits - where - getField (TxConstr (Memo (TxRaw _ w _) _)) = w - -instance HasField "txsize" (Tx era) Integer where - getField (TxConstr (Memo _ bytes)) = fromIntegral $ SBS.length bytes - --------------------------------------------------------------------------------- --- Serialisation --------------------------------------------------------------------------------- - -encodeTxRaw :: - ( ToCBOR (Core.AuxiliaryData era), - ToCBOR (Core.TxBody era), - ToCBOR (Core.Witnesses era) - ) => - TxRaw era -> - Encode ('Closed 'Dense) (TxRaw era) -encodeTxRaw TxRaw {_body, _wits, _auxiliaryData} = - Rec TxRaw - !> To _body - !> To _wits - !> E (encodeNullMaybe toCBOR . strictMaybeToMaybe) _auxiliaryData - -instance - ( Era era, - FromCBOR (Annotator (Core.TxBody era)), - FromCBOR (Annotator (Core.AuxiliaryData era)), - FromCBOR (Annotator (Core.Witnesses era)) - ) => - FromCBOR (Annotator (TxRaw era)) - where - fromCBOR = - decode $ - Ann (RecD TxRaw) - <*! From - <*! From - <*! D - ( sequence . maybeToStrictMaybe - <$> decodeNullMaybe fromCBOR - ) - -deriving via - Mem (TxRaw era) - instance - ( Era era, - FromCBOR (Annotator (Core.TxBody era)), - FromCBOR (Annotator (Core.AuxiliaryData era)), - FromCBOR (Annotator (Core.Witnesses era)) - ) => - FromCBOR (Annotator (Tx era)) - --- | Construct a Tx containing the explicit serialised bytes. --- --- This function is marked as unsafe since it makes no guarantee that the --- represented bytes are indeed the correct serialisation of the transaction. --- Thus, when calling this function, the caller is responsible for making this --- guarantee. --- --- The only intended use case for this is for segregated witness. -unsafeConstructTxWithBytes :: - Core.TxBody era -> - Core.Witnesses era -> - StrictMaybe (Core.AuxiliaryData era) -> - SBS.ShortByteString -> - Tx era -unsafeConstructTxWithBytes b w a bytes = TxConstr (Memo (TxRaw b w a) bytes) diff --git a/cardano-ledger-core/src/Cardano/Ledger/Tx.hs-boot b/cardano-ledger-core/src/Cardano/Ledger/Tx.hs-boot deleted file mode 100644 index fdcaaa45d0..0000000000 --- a/cardano-ledger-core/src/Cardano/Ledger/Tx.hs-boot +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} - --- | To break the cycle between Tx and Core, we introduce a forward-definition --- of Tx in this boot module. -module Cardano.Ledger.Tx where - -type role Tx nominal - -data Tx era diff --git a/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs b/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs index 56eabeb7ff..a88b72ac0b 100644 --- a/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs +++ b/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs @@ -77,7 +77,6 @@ import Cardano.Ledger.SafeHash (hashAnnotated) import Cardano.Ledger.Serialization (ToCBORGroup) import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..)) import Cardano.Ledger.Slot (BlockNo (..)) -import qualified Cardano.Ledger.Tx as Core (Tx (..)) import Cardano.Ledger.Val (inject, (<+>)) import Cardano.Slotting.EpochInfo (EpochInfo, fixedEpochInfo) import Cardano.Slotting.Slot (EpochSize (..), SlotNo (..)) @@ -124,6 +123,7 @@ import Shelley.Spec.Ledger.STS.Ledgers (LedgersPredicateFailure (..)) import Shelley.Spec.Ledger.STS.Pool (PoolPredicateFailure (..)) import Shelley.Spec.Ledger.STS.Utxo (UtxoEnv (..)) import Shelley.Spec.Ledger.STS.Utxow (UtxowPredicateFailure (..)) +import qualified Shelley.Spec.Ledger.Tx as Core (Tx (..)) import Shelley.Spec.Ledger.TxBody ( DCert (..), DelegCert (..), diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs index f85f28e0ee..f7933d9415 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs @@ -41,7 +41,6 @@ import Cardano.Ledger.Keys (KeyHash, KeyRole (..), SignKeyVRF) import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Shelley.Constraints (UsesValue) import Cardano.Ledger.Slot (epochInfoSize) -import Cardano.Ledger.Tx (Tx (..)) import Cardano.Ledger.Val ((<->)) import Cardano.Slotting.EpochInfo (epochInfoRange) import Cardano.Slotting.Slot (EpochSize, SlotNo) @@ -97,7 +96,7 @@ import Shelley.Spec.Ledger.Rewards ) import Shelley.Spec.Ledger.STS.NewEpoch (calculatePoolDistr) import Shelley.Spec.Ledger.STS.Tickn (TicknState (..)) -import Shelley.Spec.Ledger.Tx (WitnessSet, WitnessSetHKD (..)) +import Shelley.Spec.Ledger.Tx (Tx (..), WitnessSet, WitnessSetHKD (..)) import Shelley.Spec.Ledger.TxBody (DCert, PoolParams (..), TxIn (..), WitVKey (..)) import Shelley.Spec.Ledger.UTxO (UTxO (..)) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs index 26be733478..53647935c7 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs @@ -7,8 +7,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} @@ -58,9 +60,7 @@ module Shelley.Spec.Ledger.Tx where import Cardano.Binary - ( Annotator (..), - Decoder, - FromCBOR (fromCBOR), + ( FromCBOR (fromCBOR), ToCBOR (toCBOR), decodeWord, encodeListLen, @@ -73,8 +73,7 @@ import Cardano.Binary withSlice, ) import Cardano.Ledger.BaseTypes - ( invalidKey, - maybeToStrictMaybe, + ( maybeToStrictMaybe, ) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Credential (Credential (..)) @@ -82,14 +81,9 @@ import qualified Cardano.Ledger.Crypto as CC (Crypto) import Cardano.Ledger.Era import Cardano.Ledger.Keys import Cardano.Ledger.SafeHash (SafeToHash (..)) -import Cardano.Ledger.Serialization - ( decodeList, - decodeMapContents, - encodeFoldable, - ) -import Cardano.Ledger.Tx import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Short as SBS +import Data.Coders import Data.Constraint (Constraint) import Data.Foldable (fold) import Data.Functor.Identity (Identity) @@ -97,9 +91,11 @@ import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes) +import Data.Maybe.Strict (StrictMaybe, strictMaybeToMaybe) +import Data.MemoBytes (Mem, MemoBytes (Memo), memoBytes) import Data.Set (Set) import qualified Data.Set as Set -import Data.Typeable +import Data.Typeable (Typeable) import GHC.Generics (Generic) import GHC.Records (HasField (..)) import NoThunks.Class (AllowThunksIn (..), NoThunks (..)) @@ -116,6 +112,176 @@ import Shelley.Spec.Ledger.TxBody -- ======================================================== +data TxRaw era = TxRaw + { _body :: !(Core.TxBody era), + _wits :: !(Core.Witnesses era), + _auxiliaryData :: !(StrictMaybe (Core.AuxiliaryData era)) + } + deriving (Generic, Typeable) + +deriving instance + ( Era era, + Eq (Core.AuxiliaryData era), + Eq (Core.TxBody era), + Eq (Core.Witnesses era) + ) => + Eq (TxRaw era) + +deriving instance + ( Era era, + Show (Core.AuxiliaryData era), + Show (Core.TxBody era), + Show (Core.Witnesses era) + ) => + Show (TxRaw era) + +instance + ( Era era, + NoThunks (Core.AuxiliaryData era), + NoThunks (Core.TxBody era), + NoThunks (Core.Witnesses era) + ) => + NoThunks (TxRaw era) + +newtype Tx era = TxConstr (MemoBytes (TxRaw era)) + deriving newtype (SafeToHash, ToCBOR) + +deriving newtype instance + ( Era era, + Eq (Core.AuxiliaryData era), + Eq (Core.TxBody era), + Eq (Core.Witnesses era) + ) => + Eq (Tx era) + +deriving newtype instance + ( Era era, + Show (Core.AuxiliaryData era), + Show (Core.TxBody era), + Show (Core.Witnesses era) + ) => + Show (Tx era) + +deriving newtype instance + ( Era era, + NoThunks (Core.AuxiliaryData era), + NoThunks (Core.TxBody era), + NoThunks (Core.Witnesses era) + ) => + NoThunks (Tx era) + +pattern Tx :: + ( Era era, + ToCBOR (Core.AuxiliaryData era), + ToCBOR (Core.TxBody era), + ToCBOR (Core.Witnesses era) + ) => + Core.TxBody era -> + Core.Witnesses era -> + StrictMaybe (Core.AuxiliaryData era) -> + Tx era +pattern Tx {body, wits, auxiliaryData} <- + TxConstr + ( Memo + TxRaw + { _body = body, + _wits = wits, + _auxiliaryData = auxiliaryData + } + _ + ) + where + Tx b w a = TxConstr $ memoBytes (encodeTxRaw $ TxRaw b w a) + +{-# COMPLETE Tx #-} + +-------------------------------------------------------------------------------- +-- Field accessors +-------------------------------------------------------------------------------- + +instance + aux ~ Core.AuxiliaryData era => + HasField "auxiliaryData" (Tx era) (StrictMaybe aux) + where + getField (TxConstr (Memo (TxRaw _ _ a) _)) = a + +instance (body ~ Core.TxBody era) => HasField "body" (Tx era) body where + getField (TxConstr (Memo (TxRaw b _ _) _)) = b + +instance + (wits ~ Core.Witnesses era) => + HasField "wits" (Tx era) wits + where + getField (TxConstr (Memo (TxRaw _ w _) _)) = w + +instance HasField "txsize" (Tx era) Integer where + getField (TxConstr (Memo _ bytes)) = fromIntegral $ SBS.length bytes + +-------------------------------------------------------------------------------- +-- Serialisation +-------------------------------------------------------------------------------- + +encodeTxRaw :: + ( ToCBOR (Core.AuxiliaryData era), + ToCBOR (Core.TxBody era), + ToCBOR (Core.Witnesses era) + ) => + TxRaw era -> + Encode ('Closed 'Dense) (TxRaw era) +encodeTxRaw TxRaw {_body, _wits, _auxiliaryData} = + Rec TxRaw + !> To _body + !> To _wits + !> E (encodeNullMaybe toCBOR . strictMaybeToMaybe) _auxiliaryData + +instance + ( Era era, + FromCBOR (Annotator (Core.TxBody era)), + FromCBOR (Annotator (Core.AuxiliaryData era)), + FromCBOR (Annotator (Core.Witnesses era)) + ) => + FromCBOR (Annotator (TxRaw era)) + where + fromCBOR = + decode $ + Ann (RecD TxRaw) + <*! From + <*! From + <*! D + ( sequence . maybeToStrictMaybe + <$> decodeNullMaybe fromCBOR + ) + +deriving via + Mem (TxRaw era) + instance + ( Era era, + FromCBOR (Annotator (Core.TxBody era)), + FromCBOR (Annotator (Core.AuxiliaryData era)), + FromCBOR (Annotator (Core.Witnesses era)) + ) => + FromCBOR (Annotator (Tx era)) + +-- | Construct a Tx containing the explicit serialised bytes. +-- +-- This function is marked as unsafe since it makes no guarantee that the +-- represented bytes are indeed the correct serialisation of the transaction. +-- Thus, when calling this function, the caller is responsible for making this +-- guarantee. +-- +-- The only intended use case for this is for segregated witness. +unsafeConstructTxWithBytes :: + Core.TxBody era -> + Core.Witnesses era -> + StrictMaybe (Core.AuxiliaryData era) -> + SBS.ShortByteString -> + Tx era +unsafeConstructTxWithBytes b w a bytes = TxConstr (Memo (TxRaw b w a) bytes) + +-------------------------------------------------------------------------------- +-- Witnessing +-------------------------------------------------------------------------------- + -- | Higher Kinded Data type family HKD f a where HKD Identity a = a @@ -251,7 +417,9 @@ instance where getField = bootWits' . getField @"wits" --- ===================================== +-------------------------------------------------------------------------------- +-- Segregated witness +-------------------------------------------------------------------------------- segwitTx :: ( ToCBOR (Core.TxBody era), diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Shrinkers.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Shrinkers.hs index 16cb379fd4..43ecd4abf4 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Shrinkers.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Shrinkers.hs @@ -8,7 +8,6 @@ module Test.Shelley.Spec.Ledger.Shrinkers where import Cardano.Ledger.Coin import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Slot -import Cardano.Ledger.Tx import Cardano.Ledger.Val ((<+>), (<->)) import qualified Cardano.Ledger.Val as Val import Data.Foldable (toList) @@ -25,6 +24,7 @@ import Debug.Trace (traceShowId) import Shelley.Spec.Ledger.BlockChain import Shelley.Spec.Ledger.PParams import Shelley.Spec.Ledger.Scripts +import Shelley.Spec.Ledger.Tx import Shelley.Spec.Ledger.TxBody import Test.QuickCheck (shrinkIntegral, shrinkList) import Test.Shelley.Spec.Ledger.Utils (ShelleyTest) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Fees.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Fees.hs index 985ae5ab53..522dbc3f50 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Fees.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Fees.hs @@ -39,7 +39,6 @@ import Cardano.Ledger.Keys import Cardano.Ledger.SafeHash (hashAnnotated) import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Slot (EpochNo (..), SlotNo (..)) -import Cardano.Ledger.Tx (Tx (..)) import qualified Cardano.Ledger.Val as Val import qualified Data.ByteString.Base16.Lazy as Base16 import qualified Data.ByteString.Char8 as BS (pack) @@ -69,7 +68,8 @@ import qualified Shelley.Spec.Ledger.API as API import qualified Shelley.Spec.Ledger.Metadata as MD import Shelley.Spec.Ledger.PParams (PParams' (..), emptyPParams) import Shelley.Spec.Ledger.Tx - ( WitnessSetHKD (..), + ( Tx (..), + WitnessSetHKD (..), hashScript, ) import Shelley.Spec.Ledger.TxBody From b75367f0315e5addd30184770ce93f72f5c50865 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Fri, 9 Jul 2021 13:14:19 +0200 Subject: [PATCH 2/7] Drop 'TxInBlock' and use Core.Tx family. Since `Tx` will now be what is submitted by the wallet/node, there is no need for a separate `TxInBlock` concept. Instead, `Tx` becomes a type family (since it _will_ vary between eras) and everything is defined in those terms. As part of this, we alter the `SupportsSegWit` type class to reflect now the isomorphism between `TxSeq` and `Seq Tx`. --- alonzo/impl/src/Cardano/Ledger/Alonzo.hs | 8 ++--- .../src/Cardano/Ledger/Alonzo/Rules/Bbody.hs | 10 +++--- .../src/Cardano/Ledger/Alonzo/Rules/Ledger.hs | 10 +++--- .../src/Cardano/Ledger/Alonzo/Rules/Utxo.hs | 12 +++---- .../src/Cardano/Ledger/Alonzo/Rules/Utxow.hs | 8 ++--- .../impl/src/Cardano/Ledger/Alonzo/Tools.hs | 2 +- .../src/Cardano/Ledger/Alonzo/Translation.hs | 20 ++++-------- alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs | 2 +- cardano-ledger-core/src/Cardano/Ledger/Era.hs | 27 +++++++--------- .../impl/src/Cardano/Ledger/ShelleyMA.hs | 5 ++- .../Cardano/Ledger/ShelleyMA/Rules/Utxow.hs | 6 ++-- .../src/Cardano/Ledger/ShelleyMA/Timelocks.hs | 8 ++--- .../src/Cardano/Ledger/Shelley.hs | 3 +- .../src/Shelley/Spec/Ledger/API/Mempool.hs | 22 ++++--------- .../src/Shelley/Spec/Ledger/API/Wallet.hs | 12 ++++--- .../src/Shelley/Spec/Ledger/BlockChain.hs | 31 +++++++++---------- .../src/Shelley/Spec/Ledger/LedgerState.hs | 10 +++--- .../src/Shelley/Spec/Ledger/STS/Bbody.hs | 4 +-- .../src/Shelley/Spec/Ledger/STS/Delegs.hs | 9 ++---- .../src/Shelley/Spec/Ledger/STS/Ledger.hs | 12 +++---- .../src/Shelley/Spec/Ledger/STS/Ledgers.hs | 6 ++-- .../src/Shelley/Spec/Ledger/STS/Utxo.hs | 2 +- .../src/Shelley/Spec/Ledger/STS/Utxow.hs | 16 +++++----- .../src/Shelley/Spec/Ledger/Tx.hs | 4 +-- .../src/Shelley/Spec/Ledger/UTxO.hs | 10 +++--- 25 files changed, 118 insertions(+), 141 deletions(-) diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo.hs index c3ef90897c..7506e7e82b 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo.hs @@ -104,7 +104,6 @@ import qualified Shelley.Spec.Ledger.STS.Snap as Shelley import qualified Shelley.Spec.Ledger.STS.Tick as Shelley import qualified Shelley.Spec.Ledger.STS.Upec as Shelley import Shelley.Spec.Ledger.STS.Utxow (UtxowPredicateFailure (UtxoFailure)) -import Shelley.Spec.Ledger.Tx (Tx (Tx)) import qualified Shelley.Spec.Ledger.Tx as Shelley import Shelley.Spec.Ledger.UTxO (balance) @@ -163,8 +162,6 @@ instance API.PraosCrypto c => API.ApplyTx (AlonzoEra c) where $ TRC (env, state, tx) in liftEither . left API.ApplyTxError $ res - extractTx ValidatedTx {body = b, wits = w, auxiliaryData = a} = Tx b w a - instance API.PraosCrypto c => API.ApplyBlock (AlonzoEra c) instance (API.PraosCrypto c) => API.GetLedgerView (AlonzoEra c) @@ -230,13 +227,15 @@ instance CC.Crypto c => API.CLI (AlonzoEra c) where evaluateConsumed = consumed - addKeyWitnesses (Tx b ws aux) newWits = Tx b ws' aux + addKeyWitnesses (ValidatedTx b ws aux iv) newWits = ValidatedTx b ws' aux iv where ws' = ws {txwitsVKey = Set.union newWits (txwitsVKey ws)} evaluateMinLovelaceOutput pp out = Coin $ utxoEntrySize out * unCoin (_coinsPerUTxOWord pp) +type instance Core.Tx (AlonzoEra c) = ValidatedTx (AlonzoEra c) + type instance Core.TxOut (AlonzoEra c) = TxOut (AlonzoEra c) type instance Core.TxBody (AlonzoEra c) = TxBody (AlonzoEra c) @@ -266,7 +265,6 @@ instance CC.Crypto c => ValidateAuxiliaryData (AlonzoEra c) c where instance CC.Crypto c => EraModule.SupportsSegWit (AlonzoEra c) where type TxSeq (AlonzoEra c) = Alonzo.TxSeq (AlonzoEra c) - type TxInBlock (AlonzoEra c) = ValidatedTx (AlonzoEra c) fromTxSeq = Alonzo.txSeqTxns toTxSeq = Alonzo.TxSeq hashTxSeq = Alonzo.hashTxSeq diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs index 4ad13b3463..d54f2672bf 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs @@ -28,7 +28,7 @@ import qualified Cardano.Ledger.Alonzo.TxSeq as Alonzo (TxSeq) import Cardano.Ledger.Alonzo.TxWitness (TxWitness) import Cardano.Ledger.BaseTypes (ShelleyBase, UnitInterval, epochInfo) import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Era (Crypto), SupportsSegWit (..), TxInBlock) +import Cardano.Ledger.Era (Era (Crypto), SupportsSegWit (..)) import qualified Cardano.Ledger.Era as Era import Cardano.Ledger.Keys (DSignable, Hash, coerceKeyRole) import Cardano.Ledger.Slot (epochInfoEpoch, epochInfoFirst) @@ -139,13 +139,13 @@ bbodyTransition :: Embed (Core.EraRule "LEDGERS" era) (someBBODY era), Environment (Core.EraRule "LEDGERS" era) ~ LedgersEnv era, State (Core.EraRule "LEDGERS" era) ~ LedgerState era, - Signal (Core.EraRule "LEDGERS" era) ~ Seq (TxInBlock era), + Signal (Core.EraRule "LEDGERS" era) ~ Seq (Core.Tx era), -- Conditions to define the rule in this Era HasField "_d" (Core.PParams era) UnitInterval, HasField "_maxBlockExUnits" (Core.PParams era) ExUnits, Era era, -- supplies WellFormed HasField, and Crypto constraints Era.TxSeq era ~ Alonzo.TxSeq era, - Era.TxInBlock era ~ Alonzo.ValidatedTx era, + Core.Tx era ~ Alonzo.ValidatedTx era, Core.Witnesses era ~ TxWitness era ) => TransitionRule (someBBODY era) @@ -212,11 +212,11 @@ instance State (Core.EraRule "LEDGERS" era) ~ LedgerState era, Signal (Core.EraRule "LEDGERS" era) ~ Seq (Alonzo.ValidatedTx era), Era era, - TxInBlock era ~ Alonzo.ValidatedTx era, + Core.Tx era ~ Alonzo.ValidatedTx era, HasField "_d" (Core.PParams era) UnitInterval, HasField "_maxBlockExUnits" (Core.PParams era) ExUnits, Era.TxSeq era ~ Alonzo.TxSeq era, - Era.TxInBlock era ~ Alonzo.ValidatedTx era, + Core.Tx era ~ Alonzo.ValidatedTx era, Core.Witnesses era ~ TxWitness era, SupportsSegWit era ) => diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs index c4dfb134c2..f8da6abe18 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs @@ -26,7 +26,7 @@ import Cardano.Ledger.Alonzo.Tx (IsValidating (..), ValidatedTx (..)) import Cardano.Ledger.BaseTypes (ShelleyBase) import Cardano.Ledger.Coin (Coin) import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Crypto, Era, TxInBlock) +import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.Keys (DSignable, Hash) import Control.State.Transition ( Assertion (..), @@ -68,7 +68,7 @@ data AlonzoLEDGER era -- make it concrete. Depends only on the "certs" and "isValidating" HasField instances. ledgerTransition :: forall (someLEDGER :: Type -> Type) era. - ( Signal (someLEDGER era) ~ TxInBlock era, + ( Signal (someLEDGER era) ~ Core.Tx era, State (someLEDGER era) ~ (UTxOState era, DPState (Crypto era)), Environment (someLEDGER era) ~ LedgerEnv era, Embed (Core.EraRule "UTXOW" era) (someLEDGER era), @@ -78,9 +78,9 @@ ledgerTransition :: Signal (Core.EraRule "DELEGS" era) ~ Seq (DCert (Crypto era)), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), - HasField "isValidating" (TxInBlock era) IsValidating, + HasField "isValidating" (Core.Tx era) IsValidating, Era era ) => TransitionRule (someLEDGER era) @@ -121,7 +121,7 @@ instance Show (Core.PParamsDelta era), DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody), Era era, - TxInBlock era ~ ValidatedTx era, + Core.Tx era ~ ValidatedTx era, Embed (Core.EraRule "DELEGS" era) (AlonzoLEDGER era), Embed (Core.EraRule "UTXOW" era) (AlonzoLEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs index e0106673f7..1b788de396 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs @@ -46,7 +46,7 @@ import Cardano.Ledger.BaseTypes import Cardano.Ledger.Coin import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Credential (Credential (..)) -import Cardano.Ledger.Era (Crypto, Era, TxInBlock, ValidateScript (..)) +import Cardano.Ledger.Era (Crypto, Era, ValidateScript (..)) import qualified Cardano.Ledger.Era as Era import qualified Cardano.Ledger.Mary.Value as Alonzo (Value) import Cardano.Ledger.Rules.ValidationMode ((?!#)) @@ -257,7 +257,7 @@ feesOK :: ( Era era, ValidateScript era, -- isTwoPhaseScriptAddress Core.TxOut era ~ Alonzo.TxOut era, -- balance requires this, - Era.TxInBlock era ~ Alonzo.ValidatedTx era, + Core.Tx era ~ Alonzo.ValidatedTx era, Core.Witnesses era ~ TxWitness era, HasField "collateral" -- to get inputs to pay the fees @@ -269,7 +269,7 @@ feesOK :: HasField "_collateralPercentage" (Core.PParams era) Natural ) => Core.PParams era -> - TxInBlock era -> + Core.Tx era -> UTxO era -> Rule (AlonzoUTXO era) 'Transition () feesOK pp tx (UTxO m) = do @@ -310,7 +310,7 @@ utxoTransition :: Embed (Core.EraRule "UTXOS" era) (AlonzoUTXO era), Environment (Core.EraRule "UTXOS" era) ~ Shelley.UtxoEnv era, State (Core.EraRule "UTXOS" era) ~ Shelley.UTxOState era, - Signal (Core.EraRule "UTXOS" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOS" era) ~ Core.Tx era, -- We leave Core.PParams abstract UsesPParams era, HasField "_minfeeA" (Core.PParams era) Natural, @@ -325,11 +325,11 @@ utxoTransition :: HasField "_collateralPercentage" (Core.PParams era) Natural, HasField "_maxCollateralInputs" (Core.PParams era) Natural, -- We fix Core.Tx, Core.Value, Core.TxBody, and Core.TxOut + Core.Tx era ~ Alonzo.ValidatedTx era, Core.TxOut era ~ Alonzo.TxOut era, Core.Value era ~ Alonzo.Value (Crypto era), Core.TxBody era ~ Alonzo.TxBody era, Core.Witnesses era ~ TxWitness era, - TxInBlock era ~ Alonzo.ValidatedTx era, Era.TxSeq era ~ Alonzo.TxSeq era ) => TransitionRule (AlonzoUTXO era) @@ -493,7 +493,7 @@ instance Core.Witnesses era ~ TxWitness era, Core.TxOut era ~ Alonzo.TxOut era, Era.TxSeq era ~ Alonzo.TxSeq era, - Era.TxInBlock era ~ Alonzo.ValidatedTx era + Core.Tx era ~ Alonzo.ValidatedTx era ) => STS (AlonzoUTXO era) where diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs index 6468ce7da5..144806cb5d 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs @@ -41,7 +41,7 @@ import Cardano.Ledger.BaseTypes ) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Credential (Credential (KeyHashObj)) -import Cardano.Ledger.Era (Crypto, Era, SupportsSegWit (..), ValidateScript (..)) +import Cardano.Ledger.Era (Crypto, Era, ValidateScript (..)) import Cardano.Ledger.Keys (GenDelegs, KeyHash, KeyRole (..), asWitness) import Cardano.Ledger.Rules.ValidationMode ((?!#)) import Control.DeepSeq (NFData (..)) @@ -220,7 +220,7 @@ alonzoStyleWitness :: forall era utxow. ( Era era, -- Fix some Core types to the Alonzo Era - TxInBlock era ~ ValidatedTx era, -- scriptsNeeded, checkScriptData etc. are fixed at Alonzo.Tx + Core.Tx era ~ ValidatedTx era, -- scriptsNeeded, checkScriptData etc. are fixed at Alonzo.Tx Core.PParams era ~ PParams era, Core.Script era ~ Script era, -- Allow UTXOW to call UTXO @@ -251,7 +251,7 @@ alonzoStyleWitness = do {- txw := txwits tx -} {- witsKeyHashes := { hashKey vk | vk ∈ dom(txwitsVKey txw) } -} let utxo = _utxo u' - txbody = getField @"body" (tx :: TxInBlock era) + txbody = getField @"body" (tx :: Core.Tx era) witsKeyHashes = unWitHashes $ witsFromTxWitnesses @era tx {- { h | (_ → (a,_,h)) ∈ txins tx ◁ utxo, isNonNativeScriptAddress tx a} = dom(txdats txw) -} @@ -418,7 +418,7 @@ data AlonzoUTXOW era instance forall era. ( -- Fix some Core types to the Alonzo Era - TxInBlock era ~ ValidatedTx era, + Core.Tx era ~ ValidatedTx era, Core.PParams era ~ PParams era, Core.Script era ~ Script era, -- Allow UTXOW to call UTXO diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tools.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tools.hs index 1de2209ff5..a8b93c4004 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tools.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tools.hs @@ -20,7 +20,7 @@ import Cardano.Ledger.Alonzo.Scripts ExUnits (..), Script (..), ) -import Cardano.Ledger.Alonzo.Tx (DataHash, ScriptPurpose (Spending), rdptr) +import Cardano.Ledger.Alonzo.Tx (DataHash, ScriptPurpose (Spending), ValidatedTx (..), rdptr) import Cardano.Ledger.Alonzo.TxBody (TxOut (..)) import Cardano.Ledger.Alonzo.TxInfo (txInfo, valContext) import Cardano.Ledger.Alonzo.TxWitness (RdmrPtr (..), unRedeemers, unTxDats) diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs index fb93e32c89..889d716641 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs @@ -36,7 +36,6 @@ import Cardano.Ledger.Era TranslationContext, translateEra', ) -import qualified Cardano.Ledger.Era as Era import Cardano.Ledger.Mary (MaryEra) import Control.Monad.Except (Except, throwError) import Data.Coders @@ -86,13 +85,6 @@ instance nesPd = nesPd nes } -instance Crypto c => TranslateEra (AlonzoEra c) Core.Tx where - type TranslationError (AlonzoEra c) Core.Tx = DecoderError - translateEra _ctx tx = - case decodeAnnotator "tx" fromCBOR (serialize tx) of - Right newTx -> pure newTx - Left decoderError -> throwError decoderError - instance Crypto c => TranslateEra (AlonzoEra c) ShelleyGenesis where translateEra ctxt genesis = return @@ -114,16 +106,16 @@ instance Crypto c => TranslateEra (AlonzoEra c) ShelleyGenesis where API.sgStaking = API.sgStaking genesis } -newtype TxInBlock era = TxInBlock {unTxInBlock :: (Era.TxInBlock era)} +newtype Tx era = Tx {unTx :: Core.Tx era} instance ( Crypto c, - Era.TxInBlock (AlonzoEra c) ~ ValidatedTx (AlonzoEra c) + Core.Tx (AlonzoEra c) ~ ValidatedTx (AlonzoEra c) ) => - TranslateEra (AlonzoEra c) TxInBlock + TranslateEra (AlonzoEra c) Tx where - type TranslationError (AlonzoEra c) TxInBlock = DecoderError - translateEra _ctxt (TxInBlock tx) = do + type TranslationError (AlonzoEra c) Tx = DecoderError + translateEra _ctxt (Tx tx) = do -- Note that this does not preserve the hidden bytes field of the transaction. -- This is under the premise that this is irrelevant for TxInBlocks, which are -- not transmitted as contiguous chunks. @@ -134,7 +126,7 @@ instance SNothing -> pure SNothing SJust axd -> SJust <$> translateViaCBORAnn "auxiliarydata" axd let validating = IsValidating True - pure $ TxInBlock $ ValidatedTx bdy txwits validating aux + pure $ Tx $ ValidatedTx bdy txwits validating aux -------------------------------------------------------------------------------- -- Auxiliary instances and functions diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs index ffe4388e21..4d1d58e8b2 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs @@ -433,7 +433,7 @@ indexedRdmrs :: HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), - HasField "wits" tx (TxWitness era), -- Generalized over tx, so tx can be Tx or TxInBlock + HasField "wits" tx (TxWitness era), HasField "body" tx (Core.TxBody era) ) => tx -> diff --git a/cardano-ledger-core/src/Cardano/Ledger/Era.hs b/cardano-ledger-core/src/Cardano/Ledger/Era.hs index f300a96ebb..27ab0b3e87 100644 --- a/cardano-ledger-core/src/Cardano/Ledger/Era.hs +++ b/cardano-ledger-core/src/Cardano/Ledger/Era.hs @@ -82,12 +82,12 @@ class class ( Era era, SafeToHash (Core.Script era), - HasField "body" (TxInBlock era) (Core.TxBody era) + HasField "body" (Core.Tx era) (Core.TxBody era) ) => ValidateScript era where scriptPrefixTag :: Core.Script era -> BS.ByteString - validateScript :: Core.Script era -> TxInBlock era -> Bool + validateScript :: Core.Script era -> Core.Tx era -> Bool hashScript :: Core.Script era -> ScriptHash (Crypto era) -- ONE SHOULD NOT OVERIDE THE hashScript DEFAULT METHOD -- UNLESS YOU UNDERSTAND THE SafeToHash class, AND THE ROLE OF THE scriptPrefixTag @@ -116,21 +116,16 @@ class -- - A 'TxSeq`, which represents the decoded structure of a sequence of -- transactions as represented in the encoded block; that is, with witnessing, -- metadata and other non-body parts split separately. --- - A 'TxInBlock', which represents a transaction as included in a block. In --- general, we expect this to be the same as a normal 'Tx'. However, we know --- that in future eras it will include extra data not present when the --- transaction is first created. -- | Indicates that an era supports segregated witnessing. -- -- This class is embodies an isomorphism between 'TxSeq era' and 'StrictSeq --- (TxInBlock era)', witnessed by 'fromTxSeq' and 'toTxSeq'. +-- (Tx era)', witnessed by 'fromTxSeq' and 'toTxSeq'. class SupportsSegWit era where type TxSeq era :: Type - type TxInBlock era :: Type - fromTxSeq :: TxSeq era -> StrictSeq (TxInBlock era) - toTxSeq :: StrictSeq (TxInBlock era) -> TxSeq era + fromTxSeq :: TxSeq era -> StrictSeq (Core.Tx era) + toTxSeq :: StrictSeq (Core.Tx era) -> TxSeq era -- | Get the block body hash from the TxSeq. Note that this is not a regular -- "hash the stored bytes" function since the block body hash forms a small @@ -243,12 +238,12 @@ type WellFormed era = HasField "txfee" (Core.TxBody era) Coin, HasField "minted" (Core.TxBody era) (Set (ScriptHash (Crypto era))), HasField "adHash" (Core.TxBody era) (StrictMaybe (AuxiliaryDataHash (Crypto era))), - -- TxInBlock - HasField "body" (TxInBlock era) (Core.TxBody era), - HasField "wits" (TxInBlock era) (Core.Witnesses era), - HasField "auxiliaryData" (TxInBlock era) (StrictMaybe (Core.AuxiliaryData era)), - HasField "txsize" (TxInBlock era) Integer, - HasField "scriptWits" (TxInBlock era) (Map (ScriptHash (Crypto era)) (Core.Script era)), + -- Tx + HasField "body" (Core.Tx era) (Core.TxBody era), + HasField "wits" (Core.Tx era) (Core.Witnesses era), + HasField "auxiliaryData" (Core.Tx era) (StrictMaybe (Core.AuxiliaryData era)), + HasField "txsize" (Core.Tx era) Integer, + HasField "scriptWits" (Core.Tx era) (Map (ScriptHash (Crypto era)) (Core.Script era)), -- TxOut HasField "value" (Core.TxOut era) (Core.Value era), -- HashAnnotated diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA.hs index b7f136bae4..8dfbfdf1b6 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA.hs @@ -130,6 +130,10 @@ instance CryptoClass.Crypto c => UsesPParams (ShelleyMAEra 'Allegra c) where type instance Core.Value (ShelleyMAEra m c) = MAValue m c +type instance + Core.Tx (ShelleyMAEra (ma :: MaryOrAllegra) c) = + Tx (ShelleyMAEra ma c) + type instance Core.TxOut (ShelleyMAEra (ma :: MaryOrAllegra) c) = TxOut (ShelleyMAEra ma c) @@ -185,7 +189,6 @@ instance ) => SupportsSegWit (ShelleyMAEra ma c) where - type TxInBlock (ShelleyMAEra ma c) = Tx (ShelleyMAEra ma c) type TxSeq (ShelleyMAEra ma c) = Shelley.TxSeq (ShelleyMAEra ma c) fromTxSeq = Shelley.txSeqTxns toTxSeq = Shelley.TxSeq diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs index 7737a3e3d1..1ff0245f3d 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs @@ -12,7 +12,7 @@ module Cardano.Ledger.ShelleyMA.Rules.Utxow where import Cardano.Ledger.Address (Addr) import Cardano.Ledger.BaseTypes import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Era (Crypto), TxInBlock) +import Cardano.Ledger.Era (Era (Crypto)) import Cardano.Ledger.ShelleyMA.Rules.Utxo (UTXO, UtxoPredicateFailure) import Cardano.Ledger.ShelleyMA.TxBody () import Control.State.Transition.Extended @@ -53,14 +53,14 @@ instance Embed (Core.EraRule "UTXO" era) (UTXOW era), Environment (Core.EraRule "UTXO" era) ~ UtxoEnv era, State (Core.EraRule "UTXO" era) ~ UTxOState era, - Signal (Core.EraRule "UTXO" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXO" era) ~ Core.Tx era, -- Supply the HasField and Validate instances for Mary and Allegra (which match Shelley) ShelleyStyleWitnessNeeds era ) => STS (UTXOW era) where type State (UTXOW era) = UTxOState era - type Signal (UTXOW era) = TxInBlock era + type Signal (UTXOW era) = Core.Tx era type Environment (UTXOW era) = UtxoEnv era type BaseM (UTXOW era) = ShelleyBase type diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs index 4e2b069880..1bd0ab6d4c 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Timelocks.hs @@ -45,7 +45,7 @@ import Cardano.Binary import Cardano.Ledger.BaseTypes (StrictMaybe (SJust, SNothing)) import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CC (Crypto) -import Cardano.Ledger.Era (Era (Crypto), TxInBlock) +import Cardano.Ledger.Era (Era (Crypto)) import Cardano.Ledger.Keys (KeyHash (..), KeyRole (Witness)) import Cardano.Ledger.Pretty ( PDoc, @@ -295,10 +295,10 @@ validateTimelock :: forall era. ( UsesTxBody era, HasField "vldt" (Core.TxBody era) ValidityInterval, - HasField "addrWits" (TxInBlock era) (Set (WitVKey 'Witness (Crypto era))) + HasField "addrWits" (Core.Tx era) (Set (WitVKey 'Witness (Crypto era))) ) => Timelock (Crypto era) -> - TxInBlock era -> + Core.Tx era -> Bool validateTimelock lock tx = evalFPS @era lock vhks (getField @"body" tx) where @@ -329,7 +329,7 @@ ppTimelock (TimelockConstr (Memo (AllOf ms) _)) = ppTimelock (TimelockConstr (Memo (AnyOf ms) _)) = ppSexp "AnyOf" (foldr (:) [] (fmap ppTimelock ms)) ppTimelock (TimelockConstr (Memo (MOfN m ms) _)) = - ppSexp "MOfN" (ppInteger (fromIntegral m) : (foldr (:) [] (fmap ppTimelock ms))) + ppSexp "MOfN" (ppInteger (fromIntegral m) : foldr (:) [] (fmap ppTimelock ms)) ppTimelock (TimelockConstr (Memo (TimeExpire mslot) _)) = ppSexp "Expires" [ppSlotNo mslot] ppTimelock (TimelockConstr (Memo (TimeStart mslot) _)) = diff --git a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs index 4b441a35a6..419af1e35b 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs @@ -79,6 +79,8 @@ type instance E.TranslationContext (ShelleyEra c) = () -- Core instances -------------------------------------------------------------------------------- +type instance Core.Tx (ShelleyEra c) = STx.Tx (ShelleyEra c) + type instance Core.Value (ShelleyEra _c) = Coin type instance Core.TxBody (ShelleyEra c) = STx.TxBody (ShelleyEra c) @@ -114,7 +116,6 @@ instance validateScript = validateNativeMultiSigScript instance CryptoClass.Crypto c => SupportsSegWit (ShelleyEra c) where - type TxInBlock (ShelleyEra c) = Tx (ShelleyEra c) type TxSeq (ShelleyEra c) = Shelley.TxSeq (ShelleyEra c) fromTxSeq = Shelley.txSeqTxns toTxSeq = Shelley.TxSeq diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs index c4b2bbf96f..ca8c43b3f6 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs @@ -34,7 +34,7 @@ import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Cardano.Ledger.BaseTypes (Globals, ShelleyBase) import Cardano.Ledger.Core (AnnotatedData, ChainData, SerialisableData) import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Crypto, TxInBlock) +import Cardano.Ledger.Era (Crypto) import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Shelley.Constraints (ShelleyBased) import Cardano.Ledger.Slot (SlotNo) @@ -72,7 +72,7 @@ class BaseM (Core.EraRule "LEDGER" era) ~ ShelleyBase, Environment (Core.EraRule "LEDGER" era) ~ LedgerEnv era, State (Core.EraRule "LEDGER" era) ~ MempoolState era, - Signal (Core.EraRule "LEDGER" era) ~ TxInBlock era, + Signal (Core.EraRule "LEDGER" era) ~ Core.Tx era, PredicateFailure (Core.EraRule "LEDGER" era) ~ LedgerPredicateFailure era ) => ApplyTx era @@ -89,15 +89,14 @@ class MempoolEnv era -> MempoolState era -> Core.Tx era -> - m (MempoolState era, TxInBlock era) + m (MempoolState era, Core.Tx era) default applyTx :: - Core.Tx era ~ TxInBlock era => MonadError (ApplyTxError era) m => Globals -> MempoolEnv era -> MempoolState era -> Core.Tx era -> - m (MempoolState era, TxInBlock era) + m (MempoolState era, Core.Tx era) applyTx globals env state tx = let res = flip runReader globals @@ -124,15 +123,14 @@ class Globals -> MempoolEnv era -> MempoolState era -> - TxInBlock era -> + Core.Tx era -> m (MempoolState era) default applyTxInBlock :: - Core.Tx era ~ TxInBlock era => MonadError (ApplyTxError era) m => Globals -> MempoolEnv era -> MempoolState era -> - TxInBlock era -> + Core.Tx era -> m (MempoolState era) applyTxInBlock globals env state tx = let res = @@ -143,14 +141,6 @@ class . left ApplyTxError $ res - -- | Extract the underlying `Tx` from the `TxInBlock`. - extractTx :: TxInBlock era -> Core.Tx era - default extractTx :: - Core.Tx era ~ TxInBlock era => - TxInBlock era -> - Core.Tx era - extractTx = id - instance PraosCrypto c => ApplyTx (ShelleyEra c) type MempoolEnv era = Ledger.LedgerEnv era diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs index f7933d9415..ae39ea8fd1 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs @@ -402,7 +402,7 @@ class -- | The required fee. Coin evaluateTransactionFee pp tx numKeyWits = - evaluateMinFee pp tx' + evaluateMinFee @era pp tx' where sigSize = fromIntegral $ sizeSigDSIGN (Proxy @(DSIGN (Crypto era))) dummySig = @@ -420,11 +420,15 @@ class flip map [1 .. numKeyWits] $ \x -> WitVKey (dummyVKey x) dummySig - tx' = addKeyWitnesses tx dummyKeyWits + tx' = addKeyWitnesses @era tx dummyKeyWits -- | Evaluate the minimum lovelace that a given transaciton output must contain. evaluateMinLovelaceOutput :: Core.PParams era -> Core.TxOut era -> Coin +-------------------------------------------------------------------------------- +-- Shelley specifics +-------------------------------------------------------------------------------- + addShelleyKeyWitnesses :: ( Era era, Core.Witnesses era ~ WitnessSet era, @@ -432,9 +436,9 @@ addShelleyKeyWitnesses :: ToCBOR (Core.AuxiliaryData era), ToCBOR (Core.TxBody era) ) => - Core.Tx era -> + Tx era -> Set (WitVKey 'Witness (Crypto era)) -> - Core.Tx era + Tx era addShelleyKeyWitnesses (Tx b ws aux) newWits = Tx b ws' aux where ws' = ws {addrWits = Set.union newWits (addrWits ws)} diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BlockChain.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BlockChain.hs index d7f9b09191..1fa7f34392 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BlockChain.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BlockChain.hs @@ -151,7 +151,7 @@ import Numeric.Natural (Natural) import Shelley.Spec.Ledger.EpochBoundary (BlocksMade (..)) import Shelley.Spec.Ledger.OCert (OCert (..)) import Shelley.Spec.Ledger.PParams (ProtVer (..)) -import Shelley.Spec.Ledger.Tx (segwitTx) +import Shelley.Spec.Ledger.Tx (Tx, segwitTx) import Shelley.Spec.NonIntegral (CompareResult (..), taylorExpCmp) -- ======================================================= @@ -166,7 +166,7 @@ deriving newtype instance CC.Crypto crypto => ToCBOR (HashHeader crypto) deriving newtype instance CC.Crypto crypto => FromCBOR (HashHeader crypto) data TxSeq era = TxSeq' - { txSeqTxns' :: !(StrictSeq (Core.Tx era)), + { txSeqTxns' :: !(StrictSeq (Tx era)), txSeqBodyBytes :: BSL.ByteString, txSeqWitsBytes :: BSL.ByteString, txSeqMetadataBytes :: BSL.ByteString @@ -182,14 +182,14 @@ deriving via ] (TxSeq era) instance - (Typeable era, NoThunks (Core.Tx era)) => NoThunks (TxSeq era) + (Typeable era, NoThunks (Tx era)) => NoThunks (TxSeq era) deriving stock instance - Show (Core.Tx era) => + Show (Tx era) => Show (TxSeq era) deriving stock instance - Eq (Core.Tx era) => + Eq (Tx era) => Eq (TxSeq era) -- =========================== @@ -197,10 +197,9 @@ deriving stock instance coreWitnessBytes :: forall era. - ( SafeToHash (Core.Witnesses era), - HasField "wits" (Core.Tx era) (Core.Witnesses era) + ( SafeToHash (Core.Witnesses era) ) => - (Core.Tx era) -> + Tx era -> ByteString coreWitnessBytes coretx = originalBytes @(Core.Witnesses era) $ @@ -208,10 +207,9 @@ coreWitnessBytes coretx = coreBodyBytes :: forall era. - ( SafeToHash (Core.TxBody era), - HasField "body" (Core.Tx era) (Core.TxBody era) + ( SafeToHash (Core.TxBody era) ) => - (Core.Tx era) -> + Tx era -> ByteString coreBodyBytes coretx = originalBytes @(Core.TxBody era) $ @@ -219,12 +217,11 @@ coreBodyBytes coretx = coreAuxDataBytes :: forall era. - ( SafeToHash (Core.AuxiliaryData era), - HasField "auxiliaryData" (Core.Tx era) (StrictMaybe (Core.AuxiliaryData era)) + ( SafeToHash (Core.AuxiliaryData era) ) => - (Core.Tx era) -> + Tx era -> StrictMaybe ByteString -coreAuxDataBytes coretx = getbytes <$> getField @"auxiliaryData" @(Core.Tx era) coretx +coreAuxDataBytes coretx = getbytes <$> getField @"auxiliaryData" coretx where getbytes auxdata = originalBytes @(Core.AuxiliaryData era) auxdata @@ -236,7 +233,7 @@ pattern TxSeq :: ( Era era, SafeToHash (Core.Witnesses era) ) => - StrictSeq (Core.Tx era) -> + StrictSeq (Tx era) -> TxSeq era pattern TxSeq xs <- TxSeq' xs _ _ _ @@ -262,7 +259,7 @@ pattern TxSeq xs <- {-# COMPLETE TxSeq #-} -txSeqTxns :: TxSeq era -> StrictSeq (Core.Tx era) +txSeqTxns :: TxSeq era -> StrictSeq (Tx era) txSeqTxns (TxSeq' ts _ _ _) = ts instance diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs index 080423a40f..a6def70cb5 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs @@ -233,10 +233,7 @@ import Shelley.Spec.Ledger.Rewards percentile', sumRewards, ) -import Shelley.Spec.Ledger.Tx - ( Tx (..), - extractKeyHashWitnessSet, - ) +import Shelley.Spec.Ledger.Tx (extractKeyHashWitnessSet) import Shelley.Spec.Ledger.TxBody ( EraIndependentTxBody, Ix, @@ -781,10 +778,11 @@ txsizeBound Proxy tx = numInputs * inputSize + numOutputs * outputSize + rest -- | Minimum fee calculation minfee :: ( HasField "_minfeeA" pp Natural, - HasField "_minfeeB" pp Natural + HasField "_minfeeB" pp Natural, + HasField "txsize" tx Integer ) => pp -> - Tx era -> + tx -> Coin minfee pp tx = Coin $ diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Bbody.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Bbody.hs index d223b57b7c..d6a9069f5a 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Bbody.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Bbody.hs @@ -123,7 +123,7 @@ instance Embed (Core.EraRule "LEDGERS" era) (BBODY era), Environment (Core.EraRule "LEDGERS" era) ~ LedgersEnv era, State (Core.EraRule "LEDGERS" era) ~ LedgerState era, - Signal (Core.EraRule "LEDGERS" era) ~ Seq (Era.TxInBlock era), + Signal (Core.EraRule "LEDGERS" era) ~ Seq (Core.Tx era), HasField "_d" (Core.PParams era) UnitInterval ) => STS (BBODY era) @@ -155,7 +155,7 @@ bbodyTransition :: Embed (Core.EraRule "LEDGERS" era) (BBODY era), Environment (Core.EraRule "LEDGERS" era) ~ LedgersEnv era, State (Core.EraRule "LEDGERS" era) ~ LedgerState era, - Signal (Core.EraRule "LEDGERS" era) ~ Seq (Era.TxInBlock era), + Signal (Core.EraRule "LEDGERS" era) ~ Seq (Core.Tx era), HasField "_d" (Core.PParams era) UnitInterval ) => TransitionRule (BBODY era) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Delegs.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Delegs.hs index 90c40dae06..90af9e553e 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Delegs.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Delegs.hs @@ -35,7 +35,7 @@ import Cardano.Ledger.BaseTypes ) import Cardano.Ledger.Coin (Coin) import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Crypto, Era, TxInBlock) +import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.Keys (KeyHash, KeyRole (..)) import Cardano.Ledger.Serialization ( decodeRecordSum, @@ -74,7 +74,6 @@ import Shelley.Spec.Ledger.LedgerState _rewards, ) import Shelley.Spec.Ledger.STS.Delpl (DELPL, DelplEnv (..), DelplEvent, DelplPredicateFailure) -import Shelley.Spec.Ledger.Tx (Tx (..)) import Shelley.Spec.Ledger.TxBody ( DCert (..), DelegCert (..), @@ -91,12 +90,12 @@ data DelegsEnv era = DelegsEnv { delegsSlotNo :: SlotNo, delegsIx :: Ix, delegspp :: Core.PParams era, - delegsTx :: TxInBlock era, + delegsTx :: Core.Tx era, delegsAccount :: AccountState } deriving stock instance - ( Show (TxInBlock era), + ( Show (Core.Tx era), Show (Core.PParams era) ) => Show (DelegsEnv era) @@ -124,7 +123,6 @@ deriving stock instance instance ( ShelleyBased era, - Core.Tx era ~ Tx era, HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), Embed (Core.EraRule "DELPL" era) (DELEGS era), Environment (Core.EraRule "DELPL" era) ~ DelplEnv era, @@ -194,7 +192,6 @@ instance delegsTransition :: forall era. ( ShelleyBased era, - Core.Tx era ~ Tx era, HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), Embed (Core.EraRule "DELPL" era) (DELEGS era), Environment (Core.EraRule "DELPL" era) ~ DelplEnv era, diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Ledger.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Ledger.hs index 1bc94d59ef..51139dba37 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Ledger.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Ledger.hs @@ -33,7 +33,7 @@ import Cardano.Binary import Cardano.Ledger.BaseTypes (ShelleyBase, invalidKey) import Cardano.Ledger.Coin (Coin) import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Crypto, Era, TxInBlock) +import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.Keys (DSignable, Hash) import Cardano.Ledger.Serialization (decodeRecordSum) import Cardano.Ledger.Slot (SlotNo) @@ -143,14 +143,14 @@ instance instance ( Show (Core.PParams era), - Show (TxInBlock era), + Show (Core.Tx era), DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody), Era era, Embed (Core.EraRule "DELEGS" era) (LEDGER era), Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, Environment (Core.EraRule "DELEGS" era) ~ DelegsEnv era, State (Core.EraRule "DELEGS" era) ~ DPState (Crypto era), Signal (Core.EraRule "DELEGS" era) ~ Seq (DCert (Crypto era)), @@ -164,7 +164,7 @@ instance type State (LEDGER era) = (UTxOState era, DPState (Crypto era)) - type Signal (LEDGER era) = TxInBlock era + type Signal (LEDGER era) = Core.Tx era type Environment (LEDGER era) = LedgerEnv era type BaseM (LEDGER era) = ShelleyBase type PredicateFailure (LEDGER era) = LedgerPredicateFailure era @@ -199,9 +199,9 @@ ledgerTransition :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), - HasField "body" (TxInBlock era) (Core.TxBody era) + HasField "body" (Core.Tx era) (Core.TxBody era) ) => TransitionRule (LEDGER era) ledgerTransition = do diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Ledgers.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Ledgers.hs index b3c13dabfb..f73806dc29 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Ledgers.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Ledgers.hs @@ -112,14 +112,14 @@ instance Embed (Core.EraRule "LEDGER" era) (LEDGERS era), Environment (Core.EraRule "LEDGER" era) ~ LedgerEnv era, State (Core.EraRule "LEDGER" era) ~ (UTxOState era, DPState (Crypto era)), - Signal (Core.EraRule "LEDGER" era) ~ TxInBlock era, + Signal (Core.EraRule "LEDGER" era) ~ Core.Tx era, DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody), Default (LedgerState era) ) => STS (LEDGERS era) where type State (LEDGERS era) = LedgerState era - type Signal (LEDGERS era) = Seq (TxInBlock era) + type Signal (LEDGERS era) = Seq (Core.Tx era) type Environment (LEDGERS era) = LedgersEnv era type BaseM (LEDGERS era) = ShelleyBase type PredicateFailure (LEDGERS era) = LedgersPredicateFailure era @@ -132,7 +132,7 @@ ledgersTransition :: ( Embed (Core.EraRule "LEDGER" era) (LEDGERS era), Environment (Core.EraRule "LEDGER" era) ~ LedgerEnv era, State (Core.EraRule "LEDGER" era) ~ (UTxOState era, DPState (Crypto era)), - Signal (Core.EraRule "LEDGER" era) ~ TxInBlock era + Signal (Core.EraRule "LEDGER" era) ~ Core.Tx era ) => TransitionRule (LEDGERS era) ledgersTransition = do diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs index fe3516cf33..107e51e891 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxo.hs @@ -343,7 +343,7 @@ utxoInductive :: BaseM (utxo era) ~ ShelleyBase, Environment (utxo era) ~ UtxoEnv era, State (utxo era) ~ UTxOState era, - Signal (utxo era) ~ Tx era, + Signal (utxo era) ~ Core.Tx era, PredicateFailure (utxo era) ~ UtxoPredicateFailure era, Event (utxo era) ~ UtxoEvent era, Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era, diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxow.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxow.hs index c96874762e..a754d8a9b4 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxow.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/STS/Utxow.hs @@ -44,7 +44,7 @@ import Cardano.Ledger.BaseTypes (==>), ) import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Crypto, Era, TxInBlock) +import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.Keys ( DSignable, GenDelegPair (..), @@ -247,8 +247,8 @@ type ShelleyStyleWitnessNeeds era = ( HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), - HasField "addrWits" (TxInBlock era) (Set (WitVKey 'Witness (Crypto era))), - HasField "bootWits" (TxInBlock era) (Set (BootstrapWitness (Crypto era))), + HasField "addrWits" (Core.Tx era) (Set (WitVKey 'Witness (Crypto era))), + HasField "bootWits" (Core.Tx era) (Set (BootstrapWitness (Crypto era))), HasField "update" (Core.TxBody era) (StrictMaybe (Update era)), HasField "_protocolVersion" (Core.PParams era) ProtVer, HasField "address" (Core.TxOut era) (Addr (Crypto era)), @@ -271,7 +271,7 @@ initialLedgerStateUTXOW = do -- | Function which collects VKey witnesses. type CollectVKeyWitnesses era = UTxO era -> - TxInBlock era -> + Core.Tx era -> GenDelegs (Crypto era) -> WitHashes (Crypto era) @@ -285,10 +285,10 @@ shelleyStyleWitness :: Embed (Core.EraRule "UTXO" era) (utxow era), Environment (Core.EraRule "UTXO" era) ~ UtxoEnv era, State (Core.EraRule "UTXO" era) ~ UTxOState era, - Signal (Core.EraRule "UTXO" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXO" era) ~ Core.Tx era, Environment (utxow era) ~ UtxoEnv era, State (utxow era) ~ UTxOState era, - Signal (utxow era) ~ TxInBlock era, + Signal (utxow era) ~ Core.Tx era, -- PredicateFailure (utxow era) ~ UtxowPredicateFailure era, STS (utxow era), ShelleyStyleWitnessNeeds era @@ -396,12 +396,12 @@ instance instance ( -- Fix Core.Witnesses to the Shelley Era Core.Witnesses era ~ WitnessSet era, - TxInBlock era ~ Core.Tx era, + Core.Tx era ~ Tx era, -- Allow UTXOW to call UTXO Embed (Core.EraRule "UTXO" era) (UTXOW era), Environment (Core.EraRule "UTXO" era) ~ UtxoEnv era, State (Core.EraRule "UTXO" era) ~ UTxOState era, - Signal (Core.EraRule "UTXO" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXO" era) ~ Core.Tx era, PredicateFailure (UTXOW era) ~ UtxowPredicateFailure era, -- Supply the HasField and Validate instances for Shelley ShelleyStyleWitnessNeeds era, diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs index 53647935c7..a2ce883d1a 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Tx.hs @@ -510,7 +510,7 @@ hashMultiSigScript :: ) => MultiSig (Crypto era) -> ScriptHash (Crypto era) -hashMultiSigScript x = hashScript @era x +hashMultiSigScript = hashScript @era -- ======================================== @@ -551,7 +551,7 @@ extractKeyHashWitnessSet :: forall (r :: KeyRole) crypto. [Credential r crypto] -> Set (KeyHash 'Witness crypto) -extractKeyHashWitnessSet credentials = foldr accum Set.empty credentials +extractKeyHashWitnessSet = foldr accum Set.empty where accum (KeyHashObj hk) ans = Set.insert (asWitness hk) ans accum _other ans = ans diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/UTxO.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/UTxO.hs index c3fa6c57ee..d6a56ed9a5 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/UTxO.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/UTxO.hs @@ -290,14 +290,16 @@ getKeyHashFromRegPool (DCertPool (RegPool p)) = Just . _poolId $ p getKeyHashFromRegPool _ = Nothing txup :: - forall era. - HasField "update" (Core.TxBody era) (StrictMaybe (Update era)) => - Core.Tx era -> + forall era tx. + ( HasField "update" (Core.TxBody era) (StrictMaybe (Update era)), + HasField "body" tx (Core.TxBody era) + ) => + tx -> Maybe (Update era) txup tx = strictMaybeToMaybe (getField @"update" txbody) where txbody :: Core.TxBody era - txbody = (getField @"body" tx) + txbody = getField @"body" tx -- | Extract script hash from value address with script. getScriptHash :: Addr crypto -> Maybe (ScriptHash crypto) From 0ab8d785edb4daaf0ee0bff2802e84fd4a427b1a Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Fri, 9 Jul 2021 15:27:58 +0200 Subject: [PATCH 3/7] Add serialisation code for ValidatedTx. This serialisation is only for use when transmitting Tx from node to node, or wallet to node. --- alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs | 67 +++++++++++++++++++++ 1 file changed, 67 insertions(+) diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs index 4d1d58e8b2..f48f8ea9f3 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs @@ -66,6 +66,7 @@ module Cardano.Ledger.Alonzo.Tx segwitTx, -- Other toCBORForSizeComputation, + toCBORForMempoolSubmission, ) where @@ -89,6 +90,7 @@ import Cardano.Ledger.Alonzo.Scripts ( CostModel, ExUnits (..), Prices, + Script, Tag (..), txscriptfee, ) @@ -507,3 +509,68 @@ segwitTx witnessSet isval (maybeToStrictMaybe metadata) + +-------------------------------------------------------------------------------- +-- Mempool Serialisation +-- +-- We do not store the Tx bytes for the following reasons: +-- - A Tx serialised in this way never forms part of any hashed structure, hence +-- we do not worry about the serialisation changing and thus seeing a new +-- hash. +-- - The three principal components of this Tx already store their own bytes; +-- here we simply concatenate them. The final component, `IsValidating`, is +-- just a flag and very cheap to serialise. +-------------------------------------------------------------------------------- + +-- | Encode to CBOR for the purposes of transmission from node to node, or from +-- wallet to node. +-- +-- Note that this serialisation is neither the serialisation used on-chain +-- (where Txs are deconstructed using segwit), nor the serialisation used for +-- computing the transaction size (which omits the `IsValidating` field for +-- compatibility with Mary - see 'toCBORForSizeComputation'). +toCBORForMempoolSubmission :: + ( Typeable era, + ToCBOR (Core.TxBody era), + ToCBOR (Core.AuxiliaryData era) + ) => + ValidatedTx era -> + Encoding +toCBORForMempoolSubmission + ValidatedTx {body, wits, auxiliaryData, isValidating} = + encode $ + Rec ValidatedTx + !> To body + !> To wits + !> To isValidating + !> E (encodeNullMaybe toCBOR . strictMaybeToMaybe) auxiliaryData + +instance + ( Typeable era, + ToCBOR (Core.TxBody era), + ToCBOR (Core.AuxiliaryData era) + ) => + ToCBOR (ValidatedTx era) + where + toCBOR = toCBORForMempoolSubmission + +instance + ( Era era, + FromCBOR (Annotator (Core.TxBody era)), + FromCBOR (Annotator (Core.AuxiliaryData era)), + FromCBOR (Annotator (Core.Witnesses era)), + ValidateScript era, + Core.Script era ~ Script era + ) => + FromCBOR (Annotator (ValidatedTx era)) + where + fromCBOR = + decode $ + Ann (RecD ValidatedTx) + <*! From + <*! From + <*! Ann From + <*! D + ( sequence . maybeToStrictMaybe + <$> decodeNullMaybe fromCBOR + ) From 82700d85103326d6da1d10f81952bc2f07f584d5 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Mon, 12 Jul 2021 10:21:46 +0200 Subject: [PATCH 4/7] Rewrite mempool API in light of Tx/TxInBlock. Previously, we used the Tx/TxInBlock distinction to also embody the fact that a Tx had been validated, and hence future applications of that Tx could skip a certain number of checks, an important performance concern. Now we lack this distinction (which in any case was somewhat a conflation of concerns), so we introduce the `Validated` newtype to reflect this, and rewrite the Mempool API to reflect this. --- alonzo/impl/src/Cardano/Ledger/Alonzo.hs | 53 ++----------------- .../src/Shelley/Spec/Ledger/API/Mempool.hs | 29 ++++++---- 2 files changed, 25 insertions(+), 57 deletions(-) diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo.hs index 7506e7e82b..fb56cd098a 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo.hs @@ -32,10 +32,9 @@ import Cardano.Ledger.Alonzo.PParams ) import qualified Cardano.Ledger.Alonzo.Rules.Bbody as Alonzo (AlonzoBBODY) import qualified Cardano.Ledger.Alonzo.Rules.Ledger as Alonzo (AlonzoLEDGER) -import Cardano.Ledger.Alonzo.Rules.Utxo (UtxoPredicateFailure (UtxosFailure), utxoEntrySize) +import Cardano.Ledger.Alonzo.Rules.Utxo (utxoEntrySize) import qualified Cardano.Ledger.Alonzo.Rules.Utxo as Alonzo (AlonzoUTXO) -import qualified Cardano.Ledger.Alonzo.Rules.Utxos as Alonzo (UTXOS, constructValidated, lbl2Phase) -import Cardano.Ledger.Alonzo.Rules.Utxow (AlonzoPredFail (WrappedShelleyEraFailure)) +import qualified Cardano.Ledger.Alonzo.Rules.Utxos as Alonzo (UTXOS) import qualified Cardano.Ledger.Alonzo.Rules.Utxow as Alonzo (AlonzoUTXOW) import Cardano.Ledger.Alonzo.Scripts (Script (..), isPlutusScript) import Cardano.Ledger.Alonzo.Tx (ValidatedTx (..), minfee) @@ -53,7 +52,6 @@ import Cardano.Ledger.Keys (GenDelegs (GenDelegs)) import qualified Cardano.Ledger.Mary.Value as V (Value) import Cardano.Ledger.Rules.ValidationMode ( applySTSNonStatic, - applySTSValidateSuchThat, ) import Cardano.Ledger.SafeHash (hashAnnotated) import Cardano.Ledger.Shelley (nativeMultiSigTag) @@ -66,7 +64,7 @@ import Cardano.Ledger.ShelleyMA.Rules.Utxo (consumed) import Cardano.Ledger.ShelleyMA.Timelocks (validateTimelock) import Cardano.Ledger.Val (Val (inject), coin, (<->)) import Control.Arrow (left) -import Control.Monad.Except (liftEither, runExcept) +import Control.Monad.Except (liftEither) import Control.Monad.Reader (runReader) import Control.State.Transition.Extended (TRC (TRC)) import Data.Default (def) @@ -84,17 +82,10 @@ import Shelley.Spec.Ledger.LedgerState LedgerState (..), NewEpochState (..), UTxOState (..), - _dstate, _genDelegs, - _pParams, - _pstate, ) import Shelley.Spec.Ledger.Metadata (validMetadatum) import qualified Shelley.Spec.Ledger.STS.Epoch as Shelley -import Shelley.Spec.Ledger.STS.Ledger - ( LedgerEnv (..), - LedgerPredicateFailure (UtxowFailure), - ) import qualified Shelley.Spec.Ledger.STS.Mir as Shelley import qualified Shelley.Spec.Ledger.STS.Newpp as Shelley import qualified Shelley.Spec.Ledger.STS.Ocert as Shelley @@ -103,7 +94,6 @@ import qualified Shelley.Spec.Ledger.STS.Rupd as Shelley import qualified Shelley.Spec.Ledger.STS.Snap as Shelley import qualified Shelley.Spec.Ledger.STS.Tick as Shelley import qualified Shelley.Spec.Ledger.STS.Upec as Shelley -import Shelley.Spec.Ledger.STS.Utxow (UtxowPredicateFailure (UtxoFailure)) import qualified Shelley.Spec.Ledger.Tx as Shelley import Shelley.Spec.Ledger.UTxO (balance) @@ -121,45 +111,12 @@ instance type Crypto (AlonzoEra c) = c instance API.PraosCrypto c => API.ApplyTx (AlonzoEra c) where - applyTx globals env@(LedgerEnv slot _ix pp _accnt) st@(utxostate, dpstate) tx = - do - vtx <- - liftEither - . left - ( API.ApplyTxError - . fmap - ( UtxowFailure - . WrappedShelleyEraFailure - . UtxoFailure - . UtxosFailure - ) - ) - . runExcept - $ Alonzo.constructValidated globals utxoenv utxostate tx - -- Note here that we exclude checks of 2-phase validation, since we have - -- just constructed our own validating flag and can hence trust it! Other - -- static checks must be run, however, since we haven't computed them - -- before. - state' <- - liftEither - . left API.ApplyTxError - . flip runReader globals - . applySTSValidateSuchThat - @(Core.EraRule "LEDGER" (AlonzoEra c)) - (notElem Alonzo.lbl2Phase) - $ TRC (env, st, vtx) - pure (state', vtx) - where - delegs = (_genDelegs . _dstate) dpstate - stake = (_pParams . _pstate) dpstate - utxoenv = API.UtxoEnv slot pp stake delegs - - applyTxInBlock globals env state tx = + reapplyTx globals env state vtx = let res = flip runReader globals . applySTSNonStatic @(Core.EraRule "LEDGER" (AlonzoEra c)) - $ TRC (env, state, tx) + $ TRC (env, state, API.extractTx vtx) in liftEither . left API.ApplyTxError $ res instance API.PraosCrypto c => API.ApplyBlock (AlonzoEra c) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs index ca8c43b3f6..3926fafa02 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs @@ -16,6 +16,8 @@ module Shelley.Spec.Ledger.API.Mempool ( ApplyTx (..), ApplyTxError (..), + Validated, + extractTx, -- * Exports for testing MempoolEnv, @@ -61,6 +63,15 @@ import Shelley.Spec.Ledger.PParams (PParams' (..)) import Shelley.Spec.Ledger.STS.Ledger (LedgerEnv, LedgerPredicateFailure) import qualified Shelley.Spec.Ledger.STS.Ledger as Ledger +-- | A newtype which indicates that a transaction has been validated against +-- some chain state. +newtype Validated tx = Validated tx + deriving (Eq, Show) + +-- | Extract the underlying unvalidated Tx. +extractTx :: Validated tx -> tx +extractTx (Validated tx) = tx + class ( ChainData (Core.Tx era), AnnotatedData (Core.Tx era), @@ -89,14 +100,14 @@ class MempoolEnv era -> MempoolState era -> Core.Tx era -> - m (MempoolState era, Core.Tx era) + m (MempoolState era, Validated (Core.Tx era)) default applyTx :: MonadError (ApplyTxError era) m => Globals -> MempoolEnv era -> MempoolState era -> Core.Tx era -> - m (MempoolState era, Core.Tx era) + m (MempoolState era, Validated (Core.Tx era)) applyTx globals env state tx = let res = flip runReader globals @@ -104,10 +115,10 @@ class $ TRC (env, state, tx) in liftEither . left ApplyTxError - . right (,tx) + . right (,Validated tx) $ res - -- | Reapply a 'TxInBlock'. + -- | Reapply a previously validated 'Tx'. -- -- This applies the (validated) transaction to a new mempool state. It may -- fail due to the mempool state changing (for example, a needed output @@ -118,21 +129,21 @@ class -- any static checks. This is not required, but strongly encouraged since -- this function will be called each time the mempool revalidates -- transactions against a new mempool state. - applyTxInBlock :: + reapplyTx :: MonadError (ApplyTxError era) m => Globals -> MempoolEnv era -> MempoolState era -> - Core.Tx era -> + Validated (Core.Tx era) -> m (MempoolState era) - default applyTxInBlock :: + default reapplyTx :: MonadError (ApplyTxError era) m => Globals -> MempoolEnv era -> MempoolState era -> - Core.Tx era -> + Validated (Core.Tx era) -> m (MempoolState era) - applyTxInBlock globals env state tx = + reapplyTx globals env state (Validated tx) = let res = flip runReader globals . applySTS @(Core.EraRule "LEDGER" era) From 4999e678014fe8c10ed0b7375e67735fbdf37cee Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Mon, 12 Jul 2021 10:28:01 +0200 Subject: [PATCH 5/7] Re-introduce a TxInBlock alias for compatibility. We will drop this when downstream projects are updated. --- cardano-ledger-core/src/Cardano/Ledger/Era.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/cardano-ledger-core/src/Cardano/Ledger/Era.hs b/cardano-ledger-core/src/Cardano/Ledger/Era.hs index 27ab0b3e87..cad61f6636 100644 --- a/cardano-ledger-core/src/Cardano/Ledger/Era.hs +++ b/cardano-ledger-core/src/Cardano/Ledger/Era.hs @@ -21,6 +21,7 @@ module Cardano.Ledger.Era ValidateScript (..), -- $segWit SupportsSegWit (..), + TxInBlock, ) where @@ -137,6 +138,13 @@ class SupportsSegWit era where -- | The number of segregated components numSegComponents :: Word64 +{-# DEPRECATED TxInBlock "Please use Cardano.Ledger.Core.Tx instead." #-} + +-- | Deprecated alias for Tx. +-- +-- TODO Remove this once downstream projects have been updated. +type TxInBlock era = Core.Tx era + -------------------------------------------------------------------------------- -- Era translation -------------------------------------------------------------------------------- From 3da864b6eb12a8f9df5c0416c15991e9ac04c969 Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Mon, 12 Jul 2021 14:25:58 +0200 Subject: [PATCH 6/7] Fixup tests. Most of this is trivial. We modify `EraGen` to include a `constructTx`, which creates a transaction from its constituent parts. --- .../Cardano/Ledger/Alonzo/AlonzoEraGen.hs | 3 +- .../Ledger/Alonzo/Examples/Consensus.hs | 2 +- .../Test/Cardano/Ledger/Alonzo/Translation.hs | 27 ++++----- .../bench/Bench/Cardano/Ledger/ApplyTx.hs | 8 ++- cardano-ledger-test/cardano-ledger-test.cabal | 1 + .../Ledger/Examples/TwoPhaseValidation.hs | 7 +-- .../Test/Cardano/Ledger/Generic/Updaters.hs | 26 +++++---- example-shelley/src/Cardano/Ledger/Example.hs | 3 +- .../test/Test/Cardano/Ledger/Example.hs | 4 +- .../src/Test/Cardano/Ledger/AllegraEraGen.hs | 4 +- .../src/Test/Cardano/Ledger/MaryEraGen.hs | 4 +- .../Shelley/Spec/Ledger/Examples/Consensus.hs | 58 +++++++++---------- .../Shelley/Spec/Ledger/Generator/Block.hs | 6 +- .../Shelley/Spec/Ledger/Generator/Core.hs | 6 +- .../Shelley/Spec/Ledger/Generator/EraGen.hs | 21 ++++--- .../Spec/Ledger/Generator/ShelleyEraGen.hs | 13 +++-- .../Spec/Ledger/Generator/Trace/Ledger.hs | 19 +++--- .../Shelley/Spec/Ledger/Generator/Utxo.hs | 15 +++-- .../Serialisation/EraIndepGenerators.hs | 6 +- .../src/Test/Shelley/Spec/Ledger/Utils.hs | 8 +-- .../Shelley/Spec/Ledger/Examples/TwoPools.hs | 1 + .../test/Test/Shelley/Spec/Ledger/Fees.hs | 7 ++- .../Test/Shelley/Spec/Ledger/PropertyTests.hs | 6 +- .../Spec/Ledger/Rules/ClassifyTraces.hs | 26 ++++----- .../Shelley/Spec/Ledger/Rules/TestChain.hs | 38 ++++++------ 25 files changed, 171 insertions(+), 148 deletions(-) diff --git a/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs b/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs index 083107044e..a8e9992c35 100644 --- a/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs +++ b/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs @@ -73,7 +73,6 @@ import Plutus.V1.Ledger.Api (defaultCostModelParams) import qualified PlutusTx as P (Data (..)) import qualified PlutusTx as Plutus import Shelley.Spec.Ledger.PParams (Update) -import Shelley.Spec.Ledger.Tx (Tx (Tx)) import Shelley.Spec.Ledger.TxBody (DCert, TxIn, Wdrl) import Shelley.Spec.Ledger.UTxO (UTxO (..)) import Test.Cardano.Ledger.AllegraEraGen (genValidityInterval) @@ -336,7 +335,7 @@ instance Mock c => EraGen (AlonzoEra c) where Nothing -> ans Just info -> addRedeemMap txbody info purpose ans -- Add it to the redeemer map - unsafeApplyTx (Tx bod wit auxdata) = ValidatedTx bod wit (IsValidating True) auxdata + constructTx bod wit auxdata = ValidatedTx bod wit (IsValidating True) auxdata genEraGoodTxOut = vKeyLocked diff --git a/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/Examples/Consensus.hs b/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/Examples/Consensus.hs index fc56286f5b..cd54b31115 100644 --- a/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/Examples/Consensus.hs +++ b/alonzo/test/lib/Test/Cardano/Ledger/Alonzo/Examples/Consensus.hs @@ -56,7 +56,7 @@ ledgerExamplesAlonzo = SLE.ShelleyLedgerExamples { SLE.sleBlock = SLE.exampleShelleyLedgerBlock exampleTransactionInBlock, SLE.sleHashHeader = SLE.exampleHashHeader (Proxy @StandardAlonzo), - SLE.sleTx = exampleTx, + SLE.sleTx = exampleTransactionInBlock, SLE.sleApplyTxError = ApplyTxError $ pure $ diff --git a/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Translation.hs b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Translation.hs index 478bad039b..ce887facf2 100644 --- a/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Translation.hs +++ b/alonzo/test/test/Test/Cardano/Ledger/Alonzo/Translation.hs @@ -19,12 +19,11 @@ import Cardano.Binary import Cardano.Ledger.Alonzo (AlonzoEra) import Cardano.Ledger.Alonzo.Data (AuxiliaryData) import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..)) -import Cardano.Ledger.Alonzo.Translation (TxInBlock (..)) +import Cardano.Ledger.Alonzo.Translation (Tx (..)) import Cardano.Ledger.Alonzo.Tx (toCBORForSizeComputation) import Cardano.Ledger.Alonzo.TxBody (TxBody) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era (TranslateEra (..)) -import qualified Cardano.Ledger.Era as Era import qualified Cardano.Ledger.ShelleyMA.AuxiliaryData as MA import qualified Cardano.Ledger.ShelleyMA.TxBody as MA import Data.Typeable (Typeable) @@ -77,8 +76,7 @@ alonzoTranslationTests :: TestTree alonzoTranslationTests = testGroup "Alonzo translation binary compatibiliby tests" - [ testProperty "Tx compatibility" (test @API.Tx), - testProperty "TxInBlock compatibility" testTxInBlock, + [ testProperty "Core.Tx compatibility" testTx, testProperty "ProposedPPUpdates compatibility" (test @API.ProposedPPUpdates), testProperty "PPUPState compatibility" (test @API.PPUPState), testProperty "UTxO compatibility" (test @API.UTxO), @@ -87,16 +85,16 @@ alonzoTranslationTests = ] deriving newtype instance - (Arbitrary (Era.TxInBlock era)) => - Arbitrary (TxInBlock era) + (Arbitrary (Core.Tx era)) => + Arbitrary (Tx era) deriving newtype instance - (Typeable era, ToCBOR (Era.TxInBlock era)) => - ToCBOR (TxInBlock era) + (Typeable era, ToCBOR (Core.Tx era)) => + ToCBOR (Tx era) deriving newtype instance - (Show (Era.TxInBlock era)) => - Show (TxInBlock era) + (Show (Core.Tx era)) => + Show (Tx era) dummyAlonzoGenesis :: AlonzoGenesis dummyAlonzoGenesis = undefined @@ -110,12 +108,11 @@ test :: ) => f Mary -> Bool -test x = translationCompatToCBOR ([] :: [Alonzo]) dummyAlonzoGenesis x +test = translationCompatToCBOR ([] :: [Alonzo]) dummyAlonzoGenesis -testTxInBlock :: TxInBlock Mary -> Bool -testTxInBlock x = +testTx :: Tx Mary -> Bool +testTx = translationCompat @Alonzo dummyAlonzoGenesis - (toCBORForSizeComputation . unTxInBlock) + (toCBORForSizeComputation . unTx) toCBOR - x diff --git a/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs b/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs index 864a6948f0..1f17a53f73 100644 --- a/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs +++ b/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs @@ -13,6 +13,7 @@ module Bench.Cardano.Ledger.ApplyTx (applyTxBenchmarks) where import Cardano.Binary import Cardano.Ledger.Allegra (AllegraEra) +import Cardano.Ledger.Alonzo (AlonzoEra) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era (Era, ValidateScript) import Cardano.Ledger.Mary (MaryEra) @@ -46,6 +47,8 @@ type AllegraBench = AllegraEra C_Crypto type MaryBench = MaryEra C_Crypto +type AlonzoBench = AlonzoEra C_Crypto + -------------------------------------------------------------------------------- -- Applying a Shelley transaction in multiple eras. -- @@ -69,7 +72,7 @@ data ApplyTxRes era = ApplyTxRes { atrGlobals :: Globals, atrMempoolEnv :: MempoolEnv era, atrState :: MempoolState era, - atrTx :: Tx era + atrTx :: Core.Tx era } deriving (Generic) @@ -165,6 +168,7 @@ applyTxBenchmarks = "Deserialise Shelley Tx" [ deserialiseTxEra (Proxy @ShelleyBench), deserialiseTxEra (Proxy @AllegraBench), - deserialiseTxEra (Proxy @MaryBench) + deserialiseTxEra (Proxy @MaryBench), + deserialiseTxEra (Proxy @AlonzoBench) ] ] diff --git a/cardano-ledger-test/cardano-ledger-test.cabal b/cardano-ledger-test/cardano-ledger-test.cabal index d7aba4a90a..99dbd08765 100644 --- a/cardano-ledger-test/cardano-ledger-test.cabal +++ b/cardano-ledger-test/cardano-ledger-test.cabal @@ -96,6 +96,7 @@ benchmark bench bytestring, cardano-binary, cardano-crypto-class, + cardano-ledger-alonzo, cardano-ledger-core, cardano-ledger-shelley-ma-test, cardano-ledger-shelley-ma, diff --git a/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs b/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs index a88b72ac0b..281f96abdb 100644 --- a/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs +++ b/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/TwoPhaseValidation.hs @@ -123,7 +123,6 @@ import Shelley.Spec.Ledger.STS.Ledgers (LedgersPredicateFailure (..)) import Shelley.Spec.Ledger.STS.Pool (PoolPredicateFailure (..)) import Shelley.Spec.Ledger.STS.Utxo (UtxoEnv (..)) import Shelley.Spec.Ledger.STS.Utxow (UtxowPredicateFailure (..)) -import qualified Shelley.Spec.Ledger.Tx as Core (Tx (..)) import Shelley.Spec.Ledger.TxBody ( DCert (..), DelegCert (..), @@ -1424,8 +1423,8 @@ testUTXOW tx predicateFailure@(Left _) = do (TRC (utxoEnv (Alonzo Mock), (initialUtxoSt $ Alonzo Mock), tx)) st @?= predicateFailure -trustMe :: Bool -> Core.Tx A -> ValidatedTx A -trustMe v (Core.Tx b w a) = ValidatedTx b w (IsValidating v) a +trustMe :: Bool -> ValidatedTx A -> ValidatedTx A +trustMe iv' (ValidatedTx b w _ m) = ValidatedTx b w (IsValidating iv') m alonzoUTXOWexamples :: TestTree alonzoUTXOWexamples = @@ -1726,7 +1725,7 @@ makeNaiveBlock :: Signable (CC.DSIGN (Crypto era)) (OCertSignable (Crypto era)), KES.Signable (CC.KES (Crypto era)) (BHBody (Crypto era)) ) => - [TxInBlock era] -> + [Core.Tx era] -> Block era makeNaiveBlock txs = Block (BHeader bhb sig) txs' where diff --git a/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs b/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs index f747a5e587..018d7e7cc1 100644 --- a/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs +++ b/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs @@ -35,7 +35,8 @@ import Cardano.Ledger.Alonzo.Scripts alwaysSucceeds, ) import Cardano.Ledger.Alonzo.Tx (hashWitnessPPData) -import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody (..), TxOut (..), WitnessPPDataHash) +import qualified Cardano.Ledger.Alonzo.Tx as Alonzo +import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxOut (..)) import Cardano.Ledger.Alonzo.TxWitness (Redeemers (..), TxDats (..), TxWitness (..), unTxDats) import Cardano.Ledger.BaseTypes ( Network (..), @@ -219,7 +220,12 @@ initialTx :: forall era. Proof era -> Core.Tx era initialTx era@(Shelley _) = Shelley.Tx (initialTxBody era) (initialWitnesses era) SNothing initialTx era@(Allegra _) = Shelley.Tx (initialTxBody era) (initialWitnesses era) SNothing initialTx era@(Mary _) = Shelley.Tx (initialTxBody era) (initialWitnesses era) SNothing -initialTx era@(Alonzo _) = Shelley.Tx (initialTxBody era) (initialWitnesses era) SNothing +initialTx era@(Alonzo _) = + Alonzo.ValidatedTx + (initialTxBody era) + (initialWitnesses era) + (Alonzo.IsValidating True) + SNothing initialPParams :: forall era. Proof era -> Core.PParams era initialPParams (Shelley _) = def @@ -360,7 +366,7 @@ data TxField era | AuxData [(Core.AuxiliaryData era)] -- 0 or 1 element, represents Maybe type | Valid Bool -updateTx :: Policy -> Proof era -> Shelley.Tx era -> TxField era -> Shelley.Tx era +updateTx :: Policy -> Proof era -> Core.Tx era -> TxField era -> Core.Tx era updateTx p (wit@(Shelley _)) (tx@(Shelley.Tx b w d)) dt = case dt of Body fbody -> Shelley.Tx fbody w d @@ -385,14 +391,14 @@ updateTx p (wit@(Mary _)) (tx@(Shelley.Tx b w d)) dt = Witnesses' wfields -> Shelley.Tx b (newWitnesses p wit wfields) d AuxData faux -> Shelley.Tx b w (applySMaybe p d faux) Valid _ -> tx -updateTx p (wit@(Alonzo _)) (tx@(Shelley.Tx b w d)) dt = +updateTx p wit@(Alonzo _) (Alonzo.ValidatedTx b w iv d) dt = case dt of - Body fbody -> Shelley.Tx fbody w d - Body' bfields -> Shelley.Tx (newTxBody p wit bfields) w d - Witnesses fwit -> Shelley.Tx b fwit d - Witnesses' wfields -> Shelley.Tx b (newWitnesses p wit wfields) d - AuxData faux -> Shelley.Tx b w (applySMaybe p d faux) - Valid _ -> tx + Body fbody -> Alonzo.ValidatedTx fbody w iv d + Body' bfields -> Alonzo.ValidatedTx (newTxBody p wit bfields) w iv d + Witnesses fwit -> Alonzo.ValidatedTx b fwit iv d + Witnesses' wfields -> Alonzo.ValidatedTx b (newWitnesses p wit wfields) iv d + AuxData faux -> Alonzo.ValidatedTx b w iv (applySMaybe p d faux) + Valid iv' -> Alonzo.ValidatedTx b w (Alonzo.IsValidating iv') d newTx :: Policy -> Proof era -> [TxField era] -> Core.Tx era newTx p era = List.foldl' (updateTx p era) (initialTx era) diff --git a/example-shelley/src/Cardano/Ledger/Example.hs b/example-shelley/src/Cardano/Ledger/Example.hs index d578aeeb3c..c7b49a988b 100644 --- a/example-shelley/src/Cardano/Ledger/Example.hs +++ b/example-shelley/src/Cardano/Ledger/Example.hs @@ -107,6 +107,8 @@ instance CryptoClass.Crypto c => UsesTxOut (ExampleEra c) where -- Core instances -------------------------------------------------------------------------------- +type instance Core.Tx (ExampleEra c) = Tx (ExampleEra c) + type instance Core.Value (ExampleEra _c) = Coin type instance Core.TxBody (ExampleEra c) = TxBody (ExampleEra c) @@ -144,7 +146,6 @@ instance scriptPrefixTag _script = nativeMultiSigTag instance CryptoClass.Crypto c => SupportsSegWit (ExampleEra c) where - type TxInBlock (ExampleEra c) = Tx (ExampleEra c) type TxSeq (ExampleEra c) = Shelley.TxSeq (ExampleEra c) fromTxSeq = Shelley.txSeqTxns toTxSeq = Shelley.TxSeq diff --git a/example-shelley/test/Test/Cardano/Ledger/Example.hs b/example-shelley/test/Test/Cardano/Ledger/Example.hs index 6ef86dfff4..565c1d8db9 100644 --- a/example-shelley/test/Test/Cardano/Ledger/Example.hs +++ b/example-shelley/test/Test/Cardano/Ledger/Example.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -46,6 +47,7 @@ import Shelley.Spec.Ledger.Tx ( TxIn (..), TxOut (..), WitnessSetHKD (WitnessSet), + pattern Tx, ) import Shelley.Spec.Ledger.TxBody (TxBody (TxBody, _inputs, _outputs, _txfee), Wdrl (..)) import Test.QuickCheck @@ -98,7 +100,7 @@ instance _inputs = (_inputs body) <> ins, _outputs = (_outputs body) :|> out } - unsafeApplyTx x = x + constructTx = Tx instance CC.Crypto c => ScriptClass (ExampleEra c) where basescript _proxy = RequireSignature diff --git a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/AllegraEraGen.hs b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/AllegraEraGen.hs index f28cedc738..c4874946de 100644 --- a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/AllegraEraGen.hs +++ b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/AllegraEraGen.hs @@ -47,7 +47,7 @@ import Data.Sequence.Strict (StrictSeq (..), fromList) import qualified Data.Set as Set import Shelley.Spec.Ledger.API (KeyRole (Witness)) import Shelley.Spec.Ledger.PParams (PParams, PParams' (..), Update) -import Shelley.Spec.Ledger.Tx (pattern WitnessSet) +import Shelley.Spec.Ledger.Tx (pattern Tx, pattern WitnessSet) import Shelley.Spec.Ledger.TxBody (DCert, TxIn, TxOut (..), Wdrl) import Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators () import Test.QuickCheck (Gen, arbitrary, frequency) @@ -91,7 +91,7 @@ instance (CryptoClass.Crypto c, Mock c) => EraGen (AllegraEra c) where genEraPParamsDelta = genShelleyPParamsDelta genEraPParams = genPParams genEraWitnesses _scriptinfo setWitVKey mapScriptWit = WitnessSet setWitVKey mapScriptWit mempty - unsafeApplyTx x = x + constructTx = Tx genTxBody :: forall era. diff --git a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/MaryEraGen.hs b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/MaryEraGen.hs index 4799d21a35..effb5fe694 100644 --- a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/MaryEraGen.hs +++ b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/MaryEraGen.hs @@ -41,7 +41,7 @@ import qualified Data.Sequence.Strict as StrictSeq import qualified Data.Set as Set import GHC.Records (HasField (getField)) import Shelley.Spec.Ledger.PParams (PParams, PParams' (..), Update) -import Shelley.Spec.Ledger.Tx (TxIn, TxOut (..), hashScript, pattern WitnessSet) +import Shelley.Spec.Ledger.Tx (TxIn, TxOut (..), hashScript, pattern Tx, pattern WitnessSet) import Shelley.Spec.Ledger.TxBody (DCert, Wdrl) import Test.Cardano.Ledger.AllegraEraGen ( genValidityInterval, @@ -90,7 +90,7 @@ instance (CryptoClass.Crypto c, Mock c) => EraGen (MaryEra c) where genEraPParamsDelta = genShelleyPParamsDelta genEraPParams = genPParams genEraWitnesses _scriptinfo setWitVKey mapScriptWit = WitnessSet setWitVKey mapScriptWit mempty - unsafeApplyTx x = x + constructTx = Tx genAuxiliaryData :: Mock crypto => diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Examples/Consensus.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Examples/Consensus.hs index 25b4c95611..6e4860082f 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Examples/Consensus.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Examples/Consensus.hs @@ -17,7 +17,7 @@ import Cardano.Crypto.VRF as VRF import Cardano.Ledger.AuxiliaryData import Cardano.Ledger.BaseTypes import Cardano.Ledger.Coin -import Cardano.Ledger.Core +import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Crypto import Cardano.Ledger.Era import Cardano.Ledger.Keys @@ -65,7 +65,7 @@ type KeyPairWits era = [KeyPair 'Witness (Cardano.Ledger.Era.Crypto era)] -------------------------------------------------------------------------------} data ShelleyResultExamples era = ShelleyResultExamples - { srePParams :: Cardano.Ledger.Core.PParams era, + { srePParams :: Core.PParams era, sreProposedPPUpdates :: ProposedPPUpdates era, srePoolDistr :: PoolDistr (Cardano.Ledger.Era.Crypto era), sreNonMyopicRewards :: @@ -78,7 +78,7 @@ data ShelleyResultExamples era = ShelleyResultExamples data ShelleyLedgerExamples era = ShelleyLedgerExamples { sleBlock :: Block era, sleHashHeader :: HashHeader (Cardano.Ledger.Era.Crypto era), - sleTx :: Tx era, + sleTx :: Core.Tx era, sleApplyTxError :: ApplyTxError era, sleRewardsCredentials :: Set (Either Coin (Credential 'Staking (Cardano.Ledger.Era.Crypto era))), sleResultExamples :: ShelleyResultExamples era, @@ -93,29 +93,29 @@ data ShelleyLedgerExamples era = ShelleyLedgerExamples type ShelleyBasedEra' era = ( ShelleyBasedEra era, ToCBORGroup (TxSeq era), - ToCBOR (Witnesses era), - Default (State (EraRule "PPUP" era)) + ToCBOR (Core.Witnesses era), + Default (State (Core.EraRule "PPUP" era)) ) defaultShelleyLedgerExamples :: forall era. ( ShelleyBasedEra' era, - PredicateFailure (EraRule "DELEGS" era) + PredicateFailure (Core.EraRule "DELEGS" era) ~ DelegsPredicateFailure era, - Cardano.Ledger.Core.PParams era ~ Shelley.Spec.Ledger.PParams.PParams era, - PParamsDelta era ~ PParams' StrictMaybe era + Core.PParams era ~ Shelley.Spec.Ledger.PParams.PParams era, + Core.PParamsDelta era ~ PParams' StrictMaybe era ) => - (Cardano.Ledger.Core.TxBody era -> KeyPairWits era -> Witnesses era) -> - (Tx era -> TxInBlock era) -> - Value era -> - Cardano.Ledger.Core.TxBody era -> - AuxiliaryData era -> + (Core.TxBody era -> KeyPairWits era -> Core.Witnesses era) -> + (Tx era -> Core.Tx era) -> + Core.Value era -> + Core.TxBody era -> + Core.AuxiliaryData era -> ShelleyLedgerExamples era defaultShelleyLedgerExamples mkWitnesses mkValidatedTx value txBody auxData = ShelleyLedgerExamples { sleBlock = exampleShelleyLedgerBlock (mkValidatedTx tx), sleHashHeader = exampleHashHeader (Proxy @era), - sleTx = tx, + sleTx = mkValidatedTx tx, sleApplyTxError = ApplyTxError $ pure $ @@ -154,7 +154,7 @@ defaultShelleyLedgerExamples mkWitnesses mkValidatedTx value txBody auxData = exampleShelleyLedgerBlock :: forall era. ShelleyBasedEra' era => - TxInBlock era -> + Core.Tx era -> Block era exampleShelleyLedgerBlock tx = Block blockHeader blockBody where @@ -206,9 +206,9 @@ mkScriptHash = ScriptHash . mkDummyHash (Proxy @(ADDRHASH c)) exampleTx :: forall era. ShelleyBasedEra' era => - (Cardano.Ledger.Core.TxBody era -> KeyPairWits era -> Witnesses era) -> - Cardano.Ledger.Core.TxBody era -> - AuxiliaryData era -> + (Core.TxBody era -> KeyPairWits era -> Core.Witnesses era) -> + Core.TxBody era -> + Core.AuxiliaryData era -> Tx era exampleTx mkWitnesses txBody auxData = Tx txBody (mkWitnesses txBody keyPairWits) (SJust auxData) @@ -222,7 +222,7 @@ exampleTx mkWitnesses txBody auxData = exampleProposedPParamsUpdates :: ( ShelleyBasedEra' era, - PParamsDelta era ~ PParams' StrictMaybe era + Core.PParamsDelta era ~ PParams' StrictMaybe era ) => ProposedPPUpdates era exampleProposedPParamsUpdates = @@ -283,14 +283,14 @@ testShelleyGenesis = exampleNewEpochState :: forall era. ( ShelleyBasedEra' era, - HasField "_a0" (Cardano.Ledger.Core.PParams era) NonNegativeInterval, - HasField "_nOpt" (Cardano.Ledger.Core.PParams era) Natural, - HasField "_rho" (Cardano.Ledger.Core.PParams era) UnitInterval, - HasField "_tau" (Cardano.Ledger.Core.PParams era) UnitInterval + HasField "_a0" (Core.PParams era) NonNegativeInterval, + HasField "_nOpt" (Core.PParams era) Natural, + HasField "_rho" (Core.PParams era) UnitInterval, + HasField "_tau" (Core.PParams era) UnitInterval ) => - Value era -> - Cardano.Ledger.Core.PParams era -> - Cardano.Ledger.Core.PParams era -> + Core.Value era -> + Core.PParams era -> + Core.PParams era -> NewEpochState era exampleNewEpochState value ppp pp = NewEpochState @@ -400,7 +400,7 @@ ledgerExamplesShelley = mkWitnessesPreAlonzo :: ShelleyBasedEra' era => Proxy era -> - Cardano.Ledger.Core.TxBody era -> + Core.TxBody era -> KeyPairWits era -> WitnessSet era mkWitnessesPreAlonzo _ txBody keyPairWits = @@ -441,7 +441,7 @@ exampleMetadataMap = (4, Map [(I 3, B "b")]) ] -exampleAuxiliaryDataShelley :: AuxiliaryData StandardShelley +exampleAuxiliaryDataShelley :: Core.AuxiliaryData StandardShelley exampleAuxiliaryDataShelley = Metadata exampleMetadataMap exampleTxIns :: Cardano.Ledger.Crypto.Crypto c => Set (TxIn c) @@ -471,7 +471,7 @@ exampleWithdrawals = ] exampleProposedPPUpdates :: - ( PParamsDelta era ~ PParams' StrictMaybe era, + ( Core.PParamsDelta era ~ PParams' StrictMaybe era, ShelleyBasedEra' era ) => ProposedPPUpdates era diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Block.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Block.hs index 348bec762e..779c565957 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Block.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Block.hs @@ -12,7 +12,6 @@ module Test.Shelley.Spec.Ledger.Generator.Block ( genBlock, genBlockWithTxGen, tickChainState, - TxInBlock, ) where @@ -20,8 +19,7 @@ import qualified Cardano.Crypto.VRF as VRF import Cardano.Ledger.BaseTypes (UnitInterval) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Crypto (VRF) -import Cardano.Ledger.Era (Crypto, SupportsSegWit (TxInBlock, TxSeq)) -import qualified Cardano.Ledger.Era as Era (TxInBlock) +import Cardano.Ledger.Era (Crypto, SupportsSegWit (TxSeq)) import Cardano.Ledger.Serialization (ToCBORGroup) import Cardano.Ledger.Slot (SlotNo (..)) import Cardano.Slotting.Slot (WithOrigin (..)) @@ -75,7 +73,7 @@ type TxGen era = AccountState -> LedgerState era -> SlotNo -> - Gen (Seq (Era.TxInBlock era)) + Gen (Seq (Core.Tx era)) -- | Generate a valid block. genBlock :: diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs index 8b7007ab5a..7db4f34ecd 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Core.hs @@ -81,7 +81,7 @@ import Cardano.Ledger.Credential ) import Cardano.Ledger.Crypto (DSIGN) import qualified Cardano.Ledger.Crypto as CC (Crypto) -import Cardano.Ledger.Era (Crypto (..), SupportsSegWit (hashTxSeq, toTxSeq), TxInBlock) +import Cardano.Ledger.Era (Crypto (..), SupportsSegWit (hashTxSeq, toTxSeq)) import qualified Cardano.Ledger.Era as Era (TxSeq) import Cardano.Ledger.Hashes (EraIndependentBlockBody, EraIndependentData) import Cardano.Ledger.Keys @@ -564,7 +564,7 @@ mkBlock :: -- | All keys in the stake pool AllIssuerKeys (Crypto era) r -> -- | Transactions to record - [TxInBlock era] -> + [Core.Tx era] -> -- | Current slot SlotNo -> -- | Block number/chain length/chain "difficulty" @@ -597,7 +597,7 @@ mkBlockFakeVRF :: -- | All keys in the stake pool AllIssuerKeys (Crypto era) r -> -- | Transactions to record - [TxInBlock era] -> + [Core.Tx era] -> -- | Current slot SlotNo -> -- | Block number/chain length/chain "difficulty" diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/EraGen.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/EraGen.hs index bf79c3af55..1cb5f9e7d6 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/EraGen.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/EraGen.hs @@ -38,7 +38,7 @@ import Cardano.Ledger.BaseTypes (Network (..), ShelleyBase, StrictMaybe, UnitInt import Cardano.Ledger.Coin (Coin (..)) import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CC (Crypto, HASH) -import Cardano.Ledger.Era (Crypto, Era, TxInBlock, ValidateScript (..)) +import Cardano.Ledger.Era (Crypto, Era, ValidateScript (..)) import Cardano.Ledger.Hashes (ScriptHash) import Cardano.Ledger.Keys (KeyRole (Witness)) import Cardano.Ledger.Pretty (PrettyA (..)) @@ -119,12 +119,12 @@ import Test.Shelley.Spec.Ledger.Utils (Split (..)) type MinLEDGER_STS era = ( Environment (Core.EraRule "LEDGERS" era) ~ LedgersEnv era, BaseM (Core.EraRule "LEDGER" era) ~ ShelleyBase, - Signal (Core.EraRule "LEDGER" era) ~ TxInBlock era, + Signal (Core.EraRule "LEDGER" era) ~ Core.Tx era, State (Core.EraRule "LEDGER" era) ~ (UTxOState era, DPState (Crypto era)), Environment (Core.EraRule "LEDGER" era) ~ LedgerEnv era, BaseM (Core.EraRule "LEDGERS" era) ~ ShelleyBase, State (Core.EraRule "LEDGERS" era) ~ LedgerState era, - Signal (Core.EraRule "LEDGERS" era) ~ Seq (TxInBlock era), + Signal (Core.EraRule "LEDGERS" era) ~ Seq (Core.Tx era), STS (Core.EraRule "LEDGER" era) ) @@ -143,10 +143,10 @@ type MinUTXO_STS era = BaseM (Core.EraRule "UTXOW" era) ~ ShelleyBase, State (Core.EraRule "UTXOW" era) ~ UTxOState era, Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, State (Core.EraRule "UTXO" era) ~ UTxOState era, Environment (Core.EraRule "UTXO" era) ~ UtxoEnv era, - Signal (Core.EraRule "UTXO" era) ~ TxInBlock era + Signal (Core.EraRule "UTXO" era) ~ Core.Tx era ) -- | Minimal requirements on Core.PParams to generate random stuff @@ -274,7 +274,12 @@ class genEraGoodTxOut :: Core.TxOut era -> Bool genEraGoodTxOut _ = True -- The default implementation marks every TxOut as good. - unsafeApplyTx :: Core.Tx era -> TxInBlock era + -- | Construct a transaction given its constituent parts. + constructTx :: + Core.TxBody era -> + Core.Witnesses era -> + StrictMaybe (Core.AuxiliaryData era) -> + Core.Tx era -- | compute the delta cost of an additional script on per Era basis. genEraScriptCost :: Core.PParams era -> Core.Script era -> Coin @@ -282,12 +287,12 @@ class -- | A final opportunity to tweak things when the generator is done. Possible uses -- 1) Add tracing when debugging on a per Era basis - genEraDone :: Core.PParams era -> (Core.Tx era) -> Gen (Core.Tx era) + genEraDone :: Core.PParams era -> Core.Tx era -> Gen (Core.Tx era) genEraDone _pp x = pure x -- | A final opportunity to tweak things at the block level. Possible uses -- 2) Run a test that might decide to 'discard' the test, because we got unlucky, and a rare unfixible condition has occurred. - genEraTweakBlock :: Core.PParams era -> Seq (TxInBlock era) -> Gen (Seq (TxInBlock era)) + genEraTweakBlock :: Core.PParams era -> Seq (Core.Tx era) -> Gen (Seq (Core.Tx era)) genEraTweakBlock _pp seqTx = pure seqTx {------------------------------------------------------------------------------ diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ShelleyEraGen.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ShelleyEraGen.hs index d0a5760b21..905a7c8c75 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ShelleyEraGen.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/ShelleyEraGen.hs @@ -34,7 +34,8 @@ import Shelley.Spec.Ledger.PParams (PParams, PParams' (..)) import Shelley.Spec.Ledger.STS.EraMapping () import Shelley.Spec.Ledger.Scripts (MultiSig (..)) import Shelley.Spec.Ledger.Tx - ( TxIn (..), + ( Tx (..), + TxIn (..), TxOut (..), pattern WitnessSet, ) @@ -78,17 +79,17 @@ instance genEraTxBody _ge _utxo = genTxBody genEraAuxiliaryData = genMetadata - updateEraTxBody _utxo _pp _wits body fee ins out = - body + updateEraTxBody _utxo _pp _wits body' fee ins out = + body' { _txfee = fee, - _inputs = (_inputs body) <> ins, - _outputs = (_outputs body) :|> out + _inputs = (_inputs body') <> ins, + _outputs = (_outputs body') :|> out } genEraPParamsDelta = genShelleyPParamsDelta genEraPParams = genPParams genEraWitnesses _ setWitVKey mapScriptWit = WitnessSet setWitVKey mapScriptWit mempty - unsafeApplyTx x = x + constructTx = Tx instance CC.Crypto c => ScriptClass (ShelleyEra c) where basescript _proxy = RequireSignature diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Ledger.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Ledger.hs index 9ffd2d3040..aada8d6c80 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Ledger.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Trace/Ledger.hs @@ -20,7 +20,7 @@ module Test.Shelley.Spec.Ledger.Generator.Trace.Ledger where import Cardano.Binary (ToCBOR) import Cardano.Ledger.BaseTypes (Globals) import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Crypto, SupportsSegWit (TxInBlock)) +import Cardano.Ledger.Era (Crypto) import Cardano.Ledger.Shelley.Constraints ( TransValue, UsesAuxiliary, @@ -98,7 +98,7 @@ instance Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, Environment (Core.EraRule "DELEGS" era) ~ DelegsEnv era, State (Core.EraRule "DELEGS" era) ~ DPState (Crypto era), Signal (Core.EraRule "DELEGS" era) ~ Seq (DCert (Crypto era)), @@ -106,17 +106,16 @@ instance HasField "outputs" (Core.TxBody era) (StrictSeq (Core.TxOut era)), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), Show (State (Core.EraRule "PPUP" era)), - Show (TxInBlock era) + Show (Core.Tx era) ) => TQC.HasTrace (LEDGER era) (GenEnv era) where envGen GenEnv {geConstants} = - LedgerEnv <$> pure (SlotNo 0) - <*> pure 0 - <*> genEraPParams @era geConstants + LedgerEnv (SlotNo 0) 0 + <$> genEraPParams @era geConstants <*> genAccountState geConstants - sigGen genenv env state = unsafeApplyTx <$> genTx genenv env state + sigGen genenv env state = genTx genenv env state shrinkSignal _ = [] -- TODO add some kind of Shrinker? @@ -164,12 +163,12 @@ instance pure $ Seq.fromList (reverse txs') -- reverse Newest first to Oldest first where genAndApplyTx :: - (UTxOState era, DPState (Crypto era), [TxInBlock era]) -> + (UTxOState era, DPState (Crypto era), [Core.Tx era]) -> Ix -> - Gen (UTxOState era, DPState (Crypto era), [TxInBlock era]) + Gen (UTxOState era, DPState (Crypto era), [Core.Tx era]) genAndApplyTx (u, dp, txs) ix = do let ledgerEnv = LedgerEnv slotNo ix pParams reserves - tx <- unsafeApplyTx <$> genTx ge ledgerEnv (u, dp) + tx <- genTx ge ledgerEnv (u, dp) let res = runShelleyBase $ diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Utxo.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Utxo.hs index 44936d1f97..458136268f 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Utxo.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Generator/Utxo.hs @@ -88,7 +88,7 @@ import Shelley.Spec.Ledger.LedgerState ) import Shelley.Spec.Ledger.STS.Delpl (DelplEnv) import Shelley.Spec.Ledger.STS.Ledger (LedgerEnv (..)) -import Shelley.Spec.Ledger.Tx (Tx (..), TxIn (..)) +import Shelley.Spec.Ledger.Tx (TxIn (..)) import Shelley.Spec.Ledger.TxBody (Wdrl (..)) import Shelley.Spec.Ledger.UTxO ( UTxO (..), @@ -298,7 +298,11 @@ genTx draftFee (maybeToStrictMaybe update) (hashAuxiliaryData @era <$> metadata) - let draftTx = Tx draftTxBody (mkTxWits' draftTxBody) metadata + let draftTx = + constructTx @era + draftTxBody + (mkTxWits' draftTxBody) + metadata scripts' = Map.fromList $ map (\s -> (hashScript @era s, s)) additionalScripts -- We add now repeatedly add inputs until the process converges. converge @@ -538,7 +542,7 @@ applyDelta neededKeys neededScripts KeySpace_ {ksIndexedPaymentKeys, ksIndexedStakingKeys} - tx@(Tx _ _ _auxdata) + tx (Delta deltafees extraIn _extraWits change extraKeys extraScripts) = --fix up the witnesses here? -- Adds extraInputs, extraWitnesses, and change from delta to tx @@ -570,12 +574,13 @@ applyDelta kw sw (hashAnnotated body2) - in Tx @era body2 newWitnessSet _auxdata + in constructTx @era body2 newWitnessSet (getField @"auxiliaryData" tx) fix :: (Eq d, Monad m) => Int -> (Int -> d -> m d) -> d -> m d fix n f d = do d1 <- f n d; if d1 == d then pure d else fix (n + 1) f d1 converge :: + forall era. ( EraGen era, UsesTxOut era, Mock (Crypto era), @@ -604,7 +609,7 @@ converge keySpace tx = do delta <- genNextDeltaTilFixPoint scriptinfo initialfee keys scripts utxo pparams keySpace tx - genEraDone pparams (applyDelta utxo scriptinfo pparams neededKeys neededScripts keySpace tx delta) + genEraDone @era pparams (applyDelta utxo scriptinfo pparams neededKeys neededScripts keySpace tx delta) -- | Return up to /k/ random elements from /items/ -- (instead of the less efficient /take k <$> QC.shuffle items/) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs index 2f283cd721..928c21973e 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs @@ -825,7 +825,7 @@ genBlock :: ( Era era, ToCBORGroup (TxSeq era), Mock (Crypto era), - Arbitrary (TxInBlock era) + Arbitrary (Core.Tx era) ) => Gen (Block era) genBlock = Block <$> arbitrary <*> (toTxSeq @era <$> arbitrary) @@ -844,7 +844,7 @@ genCoherentBlock :: ToCBORGroup (TxSeq era), Mock (Crypto era), UsesTxBody era, - Arbitrary (TxInBlock era) + Arbitrary (Core.Tx era) ) => Gen (Block era) genCoherentBlock = do @@ -893,7 +893,7 @@ instance ToCBORGroup (TxSeq era), SupportsSegWit era, Mock (Crypto era), - Arbitrary (TxInBlock era) + Arbitrary (Core.Tx era) ) => Arbitrary (Block era) where diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Utils.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Utils.hs index d184e04114..c5bb33fa20 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Utils.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Utils.hs @@ -86,7 +86,7 @@ import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Credential (Credential (..), StakeReference (..)) import Cardano.Ledger.Crypto (DSIGN) import qualified Cardano.Ledger.Crypto as CC (Crypto) -import Cardano.Ledger.Era (Crypto (..), SupportsSegWit (TxInBlock)) +import Cardano.Ledger.Era (Crypto (..)) import qualified Cardano.Ledger.Era as Era import Cardano.Ledger.Keys ( KeyPair, @@ -147,8 +147,8 @@ type ChainProperty era = Mock (Crypto era), ApplyBlock era, GetLedgerView era, - Show (TxInBlock era), - Eq (TxInBlock era) + Show (Core.Tx era), + Eq (Core.Tx era) ) -- ================================================ @@ -160,8 +160,8 @@ type ShelleyTest era = UsesScript era, UsesAuxiliary era, UsesPParams era, + Core.Tx era ~ Tx era, Era.TxSeq era ~ TxSeq era, - Era.TxInBlock era ~ Tx era, TxOut era ~ Core.TxOut era, PParams era ~ Core.PParams era, Core.PParamsDelta era ~ PParamsUpdate era, diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/TwoPools.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/TwoPools.hs index 890d793bc0..cca8444dcc 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/TwoPools.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Examples/TwoPools.hs @@ -153,6 +153,7 @@ type TwoPoolsConstraints era = ( ShelleyTest era, ExMock (Crypto era), Core.TxBody era ~ TxBody era, + Core.Tx era ~ Tx era, PreAlonzo era ) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Fees.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Fees.hs index 522dbc3f50..ec534a3e16 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Fees.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Fees.hs @@ -505,7 +505,12 @@ txWithWithdrawalBytes16 = "83a50081824a93b885adfe0da089cdf600018182510075c40f44e -- | The transaction fee of txSimpleUTxO if one key witness were to be added, -- given minfeeA and minfeeB are set to 1. testEvaluateTransactionFee :: Assertion -testEvaluateTransactionFee = API.evaluateTransactionFee pp (txSimpleUTxO @C_Crypto) 1 @?= Coin 103 +testEvaluateTransactionFee = + API.evaluateTransactionFee @(ShelleyEra C_Crypto) + pp + (txSimpleUTxO @C_Crypto) + 1 + @?= Coin 103 where pp = emptyPParams {_minfeeA = 1, _minfeeB = 1} diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/PropertyTests.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/PropertyTests.hs index 1b783ac701..a4d57a6e53 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/PropertyTests.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/PropertyTests.hs @@ -32,7 +32,7 @@ import Cardano.Ledger.BaseTypes ( StrictMaybe (..), ) import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Crypto, SupportsSegWit (TxInBlock)) +import Cardano.Ledger.Era (Crypto) import Cardano.Ledger.Keys (KeyRole (Witness)) import Cardano.Ledger.Shelley.Constraints (TransValue) import Control.State.Transition @@ -93,7 +93,7 @@ minimalPropertyTests :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, State (Core.EraRule "PPUP" era) ~ PPUPState era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), @@ -134,7 +134,7 @@ propertyTests :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, State (Core.EraRule "PPUP" era) ~ PPUPState era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs index bc546a8cd7..488f4568c3 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/ClassifyTraces.hs @@ -22,7 +22,7 @@ where import Cardano.Binary (ToCBOR, serialize') import Cardano.Ledger.BaseTypes (StrictMaybe (..), epochInfo) import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Crypto, Era, SupportsSegWit (TxInBlock, fromTxSeq)) +import Cardano.Ledger.Era (Crypto, Era, SupportsSegWit (fromTxSeq)) import Cardano.Ledger.Shelley.Constraints (UsesTxBody) import Cardano.Ledger.Slot (SlotNo (..), epochInfoSize) import Cardano.Slotting.Slot (EpochSize (..)) @@ -134,7 +134,7 @@ relevantCasesAreCoveredForTrace :: Trace (CHAIN era) -> Property relevantCasesAreCoveredForTrace tr = do - let blockTxs :: Block era -> [TxInBlock era] + let blockTxs :: Block era -> [Core.Tx era] blockTxs (Block' _ txSeq _) = toList (fromTxSeq @era txSeq) bs = traceSignals OldestFirst tr txs = concat (blockTxs <$> bs) @@ -238,9 +238,9 @@ scriptCredentialCertsRatio certs = certsByTx :: forall era. ( HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), - HasField "body" (TxInBlock era) (Core.TxBody era) + HasField "body" (Core.Tx era) (Core.TxBody era) ) => - [TxInBlock era] -> + [Core.Tx era] -> [[DCert (Crypto era)]] certsByTx txs = toList . (getField @"certs") . getField @"body" <$> txs @@ -272,17 +272,17 @@ txScriptOutputsRatio _ txoutsList = hasWithdrawal :: ( HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), - HasField "body" (TxInBlock era) (Core.TxBody era) + HasField "body" (Core.Tx era) (Core.TxBody era) ) => - TxInBlock era -> + Core.Tx era -> Bool hasWithdrawal x = (not . null . unWdrl . (getField @"wdrls") . getField @"body") x hasPParamUpdate :: ( HasField "update" (Core.TxBody era) (StrictMaybe (PParams.Update era)), - HasField "body" (TxInBlock era) (Core.TxBody era) + HasField "body" (Core.Tx era) (Core.TxBody era) ) => - TxInBlock era -> + Core.Tx era -> Bool hasPParamUpdate tx = ppUpdates . getField @"update" . getField @"body" $ tx @@ -294,7 +294,7 @@ hasMetadata :: forall era. ( UsesTxBody era ) => - TxInBlock era -> + Core.Tx era -> Bool hasMetadata tx = f . getField @"adHash" . getField @"body" $ tx @@ -332,7 +332,7 @@ propAbstractSizeBoundsBytes :: ChainProperty era, QC.HasTrace (LEDGER era) (GenEnv era), HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), - ToCBOR (TxInBlock era), -- Arises from propAbstractSizeNotTooBig (which serializes) + ToCBOR (Core.Tx era), -- Arises from propAbstractSizeNotTooBig (which serializes) Default (State (Core.EraRule "PPUP" era)) ) => Property @@ -345,7 +345,7 @@ propAbstractSizeBoundsBytes = property $ do (genEnv p) genesisLedgerSt $ \tr -> do - let txs :: [TxInBlock era] + let txs :: [Core.Tx era] txs = traceSignals OldestFirst tr all (\tx -> txsizeBound (Proxy @era) tx >= numBytes tx) txs where @@ -360,7 +360,7 @@ propAbstractSizeNotTooBig :: ( EraGen era, ChainProperty era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), - ToCBOR (TxInBlock era), -- We need to serialize it to get its size. + ToCBOR (Core.Tx era), -- We need to serialize it to get its size. QC.HasTrace (LEDGER era) (GenEnv era), Default (State (Core.EraRule "PPUP" era)) ) => @@ -381,7 +381,7 @@ propAbstractSizeNotTooBig = property $ do (genEnv p) genesisLedgerSt $ \tr -> do - let txs :: [TxInBlock era] + let txs :: [Core.Tx era] txs = traceSignals OldestFirst tr all notTooBig txs where diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/TestChain.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/TestChain.hs index 2ece551042..c7b23cee6c 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/TestChain.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/TestChain.hs @@ -27,7 +27,7 @@ import Cardano.Binary (ToCBOR) import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import Cardano.Ledger.Coin import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Crypto, Era, SupportsSegWit (TxInBlock, fromTxSeq)) +import Cardano.Ledger.Era (Crypto, Era, SupportsSegWit (fromTxSeq)) import Cardano.Ledger.Keys (KeyHash, KeyRole (Witness)) import Cardano.Ledger.Shelley.Constraints (TransValue, UsesPParams, UsesValue) import Cardano.Ledger.Val ((<+>), (<->)) @@ -149,7 +149,7 @@ collisionFreeComplete :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "addrWits" (Core.Witnesses era) (Set (WitVKey 'Witness (Crypto era))), @@ -185,7 +185,7 @@ adaPreservationChain :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), @@ -355,7 +355,7 @@ checkPreservation SourceSignalTarget {source, target, signal} = -- then the total rewards should change only by withdrawals checkWithdrawlBound :: ( SupportsSegWit era, - HasField "body" (TxInBlock era) (Core.TxBody era), + HasField "body" (Core.Tx era) (Core.TxBody era), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)) ) => SourceSignalTarget (CHAIN era) -> @@ -428,7 +428,7 @@ potsSumIncreaseWdrlsPerTx :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), HasField "_keyDeposit" (Core.PParams era) Coin, @@ -464,7 +464,7 @@ potsSumIncreaseByRewardsPerTx :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "_keyDeposit" (Core.PParams era) Coin, HasField "_poolDeposit" (Core.PParams era) Coin, @@ -505,7 +505,7 @@ potsRewardsDecreaseByWdrlsPerTx :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), HasField "_keyDeposit" (Core.PParams era) Coin, @@ -554,7 +554,7 @@ preserveBalance :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), Show (State (Core.EraRule "PPUP" era)), @@ -602,7 +602,7 @@ preserveBalanceRestricted :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), @@ -646,7 +646,7 @@ preserveOutputsTx :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "_keyDeposit" (Core.PParams era) Coin, HasField "_poolDeposit" (Core.PParams era) Coin, @@ -677,7 +677,7 @@ eliminateTxInputs :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "_keyDeposit" (Core.PParams era) Coin, @@ -709,7 +709,7 @@ newEntriesAndUniqueTxIns :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "_keyDeposit" (Core.PParams era) Coin, HasField "_poolDeposit" (Core.PParams era) Coin, @@ -753,7 +753,7 @@ requiredMSigSignaturesSubset :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), Show (State (Core.EraRule "PPUP" era)) ) => @@ -773,7 +773,7 @@ requiredMSigSignaturesSubset SourceSignalTarget {source = chainSt, signal = bloc existsReqKeyComb keyHashes msig = any (\kl -> (Set.fromList kl) `Set.isSubsetOf` keyHashes) (scriptKeyCombinations (Proxy @era) msig) - keyHashSet :: TxInBlock era -> Set (KeyHash 'Witness (Crypto era)) + keyHashSet :: Core.Tx era -> Set (KeyHash 'Witness (Crypto era)) keyHashSet tx_ = Set.map witKeyHash (getField @"addrWits" . getField @"wits" $ tx_) @@ -790,10 +790,10 @@ noDoubleSpend SourceSignalTarget {signal} = where txs = toList $ (fromTxSeq @era . bbody) signal - getDoubleInputs :: [TxInBlock era] -> [(TxInBlock era, [TxInBlock era])] + getDoubleInputs :: [Core.Tx era] -> [(Core.Tx era, [Core.Tx era])] getDoubleInputs [] = [] getDoubleInputs (t : ts) = lookForDoubleSpends t ts ++ getDoubleInputs ts - lookForDoubleSpends :: TxInBlock era -> [TxInBlock era] -> [(TxInBlock era, [TxInBlock era])] + lookForDoubleSpends :: Core.Tx era -> [Core.Tx era] -> [(Core.Tx era, [Core.Tx era])] lookForDoubleSpends _ [] = [] lookForDoubleSpends tx_j ts = if null doubles then [] else [(tx_j, doubles)] @@ -810,7 +810,7 @@ noDoubleSpend SourceSignalTarget {signal} = withdrawals :: forall era. ( HasField "wdrls" (Core.TxBody era) (Wdrl (Crypto era)), - HasField "body" (TxInBlock era) (Core.TxBody era), + HasField "body" (Core.Tx era) (Core.TxBody era), SupportsSegWit era ) => Block era -> @@ -986,7 +986,7 @@ ledgerTraceFromBlock :: Embed (Core.EraRule "UTXOW" era) (LEDGER era), Environment (Core.EraRule "UTXOW" era) ~ UtxoEnv era, State (Core.EraRule "UTXOW" era) ~ UTxOState era, - Signal (Core.EraRule "UTXOW" era) ~ TxInBlock era, + Signal (Core.EraRule "UTXOW" era) ~ Core.Tx era, HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "_keyDeposit" (Core.PParams era) Coin, HasField "_poolDeposit" (Core.PParams era) Coin, @@ -1078,7 +1078,7 @@ ledgerTraceBase :: ( ChainState era, LedgerEnv era, (UTxOState era, DPState (Crypto era)), - [TxInBlock era] + [Core.Tx era] ) ledgerTraceBase chainSt block = ( tickedChainSt, From 712bdb02ebd0a02998cdccb9c133f0574328132f Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Thu, 15 Jul 2021 11:58:05 +0200 Subject: [PATCH 7/7] Add 'NoThunks' and 'TranslateEra' for Validated Approximately, for the 'TranslateEra' instance. --- .../src/Shelley/Spec/Ledger/API/Mempool.hs | 25 +++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs index 3926fafa02..baad8bf20d 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs @@ -1,8 +1,10 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -18,6 +20,8 @@ module Shelley.Spec.Ledger.API.Mempool ApplyTxError (..), Validated, extractTx, + coerceValidated, + translateValidated, -- * Exports for testing MempoolEnv, @@ -36,7 +40,7 @@ import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Cardano.Ledger.BaseTypes (Globals, ShelleyBase) import Cardano.Ledger.Core (AnnotatedData, ChainData, SerialisableData) import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Era (Crypto) +import Cardano.Ledger.Era (Crypto, PreviousEra, TranslateEra (translateEra), TranslationContext, TranslationError) import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Shelley.Constraints (ShelleyBased) import Cardano.Ledger.Slot (SlotNo) @@ -53,9 +57,11 @@ import Control.State.Transition.Extended TRC (..), applySTS, ) +import Data.Coerce (Coercible, coerce) import Data.Functor ((<&>)) import Data.Sequence (Seq) import Data.Typeable (Typeable) +import NoThunks.Class (NoThunks) import Shelley.Spec.Ledger.API.Protocol (PraosCrypto) import Shelley.Spec.Ledger.LedgerState (NewEpochState) import qualified Shelley.Spec.Ledger.LedgerState as LedgerState @@ -66,12 +72,27 @@ import qualified Shelley.Spec.Ledger.STS.Ledger as Ledger -- | A newtype which indicates that a transaction has been validated against -- some chain state. newtype Validated tx = Validated tx - deriving (Eq, Show) + deriving (Eq, NoThunks, Show) -- | Extract the underlying unvalidated Tx. extractTx :: Validated tx -> tx extractTx (Validated tx) = tx +coerceValidated :: Coercible a b => Validated a -> Validated b +coerceValidated (Validated a) = Validated $ coerce a + +-- | Translate a validated transaction across eras. +-- +-- This is not a `TranslateEra` instance since `Validated` is not itself +-- era-parametrised. +translateValidated :: + forall era f. + (TranslateEra era f) => + TranslationContext era -> + Validated (f (PreviousEra era)) -> + Except (TranslationError era f) (Validated (f era)) +translateValidated ctx (Validated tx) = Validated <$> translateEra @era ctx tx + class ( ChainData (Core.Tx era), AnnotatedData (Core.Tx era),