From f5bac403b4fb5d943a792200f4cedd10aa843a64 Mon Sep 17 00:00:00 2001 From: Tim Sheard Date: Wed, 24 Feb 2021 09:18:50 +1100 Subject: [PATCH] Added module Cardano.Ledger.Alonzo.Rules.Utxo. After discussion with Nick, we decided to leave PParams abstract, but make every thing else abstract. Needed to lessen the constraints on Era generaic functions 'produced', 'consumed', 'txouts', and 'txid', which were all way over constrained. Moved feesOK and minfee from Cardano.Ledger.Alonzo.Tx to Cardano.Ledger.Alonzo.Rules.Utxo. --- alonzo/impl/cardano-ledger-alonzo.cabal | 3 + .../impl/src/Cardano/Ledger/Alonzo/PParams.hs | 10 + .../src/Cardano/Ledger/Alonzo/Rules/Utxo.hs | 466 ++++++++++++++++++ alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs | 104 ++-- .../impl/src/Cardano/Ledger/Alonzo/TxBody.hs | 112 +++-- .../Cardano/Ledger/ShelleyMA/Rules/Utxo.hs | 9 +- .../src/Shelley/Spec/Ledger/LedgerState.hs | 9 +- .../src/Shelley/Spec/Ledger/UTxO.hs | 20 +- 8 files changed, 624 insertions(+), 109 deletions(-) create mode 100644 alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs diff --git a/alonzo/impl/cardano-ledger-alonzo.cabal b/alonzo/impl/cardano-ledger-alonzo.cabal index ffcdc3f317b..3765498c470 100644 --- a/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/alonzo/impl/cardano-ledger-alonzo.cabal @@ -28,6 +28,7 @@ library Cardano.Ledger.Alonzo.Tx Cardano.Ledger.Alonzo.TxBody Cardano.Ledger.Alonzo.TxWitness + Cardano.Ledger.Alonzo.Rules.Utxo build-depends: base >=4.14 && <4.15, bytestring, @@ -35,11 +36,13 @@ library cardano-crypto-class, cardano-ledger-shelley-ma, cardano-prelude, + cardano-slotting, containers, deepseq, nothunks, plutus-ledger-api, plutus-tx, + transformers, shelley-spec-ledger, small-steps, text diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs index 0fd683af16c..e41ee285336 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -31,6 +32,7 @@ module Cardano.Ledger.Alonzo.PParams updatePParams, getLanguageView, LangDepView (..), + PParamFeeInfo, ) where @@ -46,6 +48,7 @@ import Cardano.Ledger.Alonzo.Scripts ExUnits (..), Prices (..), ) +import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.Era import Cardano.Ledger.SafeHash ( EraIndependentPParamView, @@ -77,6 +80,7 @@ import Data.Maybe (fromMaybe) import Data.MemoBytes (MemoBytes (..), memoBytes) import Data.Typeable import GHC.Generics (Generic) +import GHC.Records (HasField (..)) import NoThunks.Class (InspectHeapNamed (..), NoThunks (..)) import Numeric.Natural (Natural) import Shelley.Spec.Ledger.BaseTypes @@ -552,3 +556,9 @@ getLanguageView pp PlutusV1 = case Map.lookup PlutusV1 (_costmdls pp) of Just x -> (PlutusView x) Nothing -> error ("CostModel map does not have cost for language: " ++ show PlutusV1) + +type PParamFeeInfo era = + ( HasField "_minfeeA" (Core.PParams era) Natural, + HasField "_minfeeB" (Core.PParams era) Natural, + HasField "_prices" (Core.PParams era) Prices + ) diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs new file mode 100644 index 00000000000..c27c115df5c --- /dev/null +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs @@ -0,0 +1,466 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +-- The STS instance for UTXO is technically an orphan. +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Alonzo.Rules.Utxo where + +import Cardano.Binary (FromCBOR (..), ToCBOR (..), serialize) +import Cardano.Ledger.Alonzo.PParams () +import Cardano.Ledger.Alonzo.Scripts (ExUnits (..), Prices, scriptfee) +import Cardano.Ledger.Alonzo.Tx + ( Tx (..), + isNonNativeScriptAddress, + txbody, + txsize, + ) +import Cardano.Ledger.Alonzo.TxBody + ( TxOut (..), + txExunits, + txUpdates, + txfee, + txinputs_fee, + ) +import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo (TxBody, TxOut) +import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.Era (Crypto, Era) +import qualified Cardano.Ledger.Mary.Value as Alonzo (Value) +import Cardano.Ledger.Shelley.Constraints + ( TransValue, + UsesPParams, + ) +{- + ( PParams, + PParams'(_maxTxExUnits), + ) +-} + +import Cardano.Ledger.ShelleyMA.Rules.Utxo (consumed, scaledMinDeposit) +import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..), inInterval) +import Cardano.Ledger.Val ((<+>), (<×>)) +import qualified Cardano.Ledger.Val as Val +import Cardano.Slotting.Slot (SlotNo) +import Control.Iterate.SetAlgebra (dom, eval, (⊆), (◁), (➖)) +import Control.Monad.Trans.Reader (asks) +import Control.State.Transition.Extended +import qualified Data.ByteString.Lazy as BSL (length) +import Data.Coders + ( Decode (..), + Encode (..), + Wrapped (Open), + decode, + decodeList, + decodeSet, + encode, + encodeFoldable, + (!>), + ( + Show (UtxoPredicateFailure era) + +deriving stock instance + ( Shelley.TransUTxOState Eq era, + TransValue Eq era, + Eq (PredicateFailure (Core.EraRule "PPUP" era)) + ) => + Eq (UtxoPredicateFailure era) + +instance + ( Shelley.TransUTxOState NoThunks era, + NoThunks (PredicateFailure (Core.EraRule "PPUP" era)) + ) => + NoThunks (UtxoPredicateFailure era) + +-- ==================================== + +minfee :: + ( HasField "_minfeeA" (Core.PParams era) Natural, + HasField "_minfeeB" (Core.PParams era) Natural, + HasField "_prices" (Core.PParams era) Prices + ) => + Core.PParams era -> + Tx era -> + Coin +minfee pp tx = + ((txsize tx) <×> a) + <+> b + <+> (scriptfee (getField @"_prices" pp) (txExunits (txbody tx))) + where + a = Coin (fromIntegral (getField @"_minfeeA" pp)) + b = Coin (fromIntegral (getField @"_minfeeB" pp)) + +-- ======================================= +-- feesOK is a predicate with 3 parts. Newly introduced in the +-- Alonzo era. We can think of as "Returning" True, if all 3 +-- parts are True. As a TransitionRule it will return (), and +-- raise an error (rather than return) if any of the 3 parts are False. + +feesOK :: + forall era. + ( Core.Value era ~ Alonzo.Value (Crypto era), + Core.TxOut era ~ Alonzo.TxOut era, + ValidateScript era, + HasField "_minfeeA" (Core.PParams era) Natural, + HasField "_minfeeB" (Core.PParams era) Natural, + HasField "_prices" (Core.PParams era) Prices + ) => + Core.PParams era -> + Tx era -> + UTxO era -> + Rule (AlonzoUTXO era) 'Transition () +feesOK pp tx (UTxO m) = do + let txb = txbody tx + fees = txinputs_fee txb + utxoFees = eval (fees ◁ m) -- compute the domain restriction to those inputs where fees are paid + bal = Val.coin (balance @era (UTxO utxoFees)) + nonNative txout = isNonNativeScriptAddress tx (getField @"address" (txout :: (TxOut era))) + -- Part 1 + (bal >= txfee txb) ?! FeeTooSmallUTxO bal (txfee txb) + -- Part 2 + (all (not . nonNative) utxoFees) ?! ScriptsNotPaidUTxO (UTxO (Map.filter nonNative utxoFees)) + -- Part 3 + (minfee pp tx <= txfee txb) ?! FeeNotBalancedUTxO (minfee pp tx) (txfee txb) + pure () + +-- ================================================================ + +-- | The UTxO transition rule for the Alonzo eras. +utxoTransition :: + forall era. + ( ValidateScript era, + Embed (Core.EraRule "PPUP" era) (AlonzoUTXO era), + Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era, + State (Core.EraRule "PPUP" era) ~ PPUPState era, + Signal (Core.EraRule "PPUP" era) ~ StrictMaybe (Update era), + -- We leave Core.PParams abstract + UsesPParams era, + HasField "_minfeeA" (Core.PParams era) Natural, + HasField "_minfeeB" (Core.PParams era) Natural, + HasField "_keyDeposit" (Core.PParams era) Coin, + HasField "_poolDeposit" (Core.PParams era) Coin, + HasField "_minUTxOValue" (Core.PParams era) Coin, + HasField "_maxTxSize" (Core.PParams era) Natural, + HasField "_prices" (Core.PParams era) Prices, + HasField "_maxTxExUnits" (Core.PParams era) ExUnits, + -- We fix Core.Value, Core.TxBody, and Core.TxOut + Core.Value era ~ Alonzo.Value (Crypto era), + Core.TxBody era ~ Alonzo.TxBody era, + Core.TxOut era ~ Alonzo.TxOut era + ) => + TransitionRule (AlonzoUTXO era) +utxoTransition = do + TRC (Shelley.UtxoEnv slot pp stakepools genDelegs, u, tx) <- judgmentContext + let Shelley.UTxOState utxo _deposits _fees ppup = u + + let txb = txbody tx + + inInterval slot (getField @"vldt" txb) + ?! OutsideValidityIntervalUTxO (getField @"vldt" txb) slot + + txins @era txb /= Set.empty ?! InputSetEmptyUTxO + + feesOK pp tx utxo + + let minimumFee = minfee pp tx + txFee = getField @"txfee" txb + minimumFee <= txFee ?! FeeTooSmallUTxO minimumFee txFee + + eval (txins @era txb ⊆ dom utxo) + ?! BadInputsUTxO (eval ((txins @era txb) ➖ (dom utxo))) + + ni <- liftSTS $ asks networkId + let addrsWrongNetwork = + filter + (\a -> getNetwork a /= ni) + (fmap (getField @"address") $ toList $ getField @"outputs" txb) + null addrsWrongNetwork ?! WrongNetwork ni (Set.fromList addrsWrongNetwork) + let wdrlsWrongNetwork = + filter + (\a -> getRwdNetwork a /= ni) + (Map.keys . unWdrl . getField @"wdrls" $ txb) + null wdrlsWrongNetwork + ?! WrongNetworkWithdrawal + ni + (Set.fromList wdrlsWrongNetwork) + + let consumed_ = consumed pp utxo txb + produced_ = Shelley.produced @era pp stakepools txb + consumed_ == produced_ ?! ValueNotConservedUTxO consumed_ produced_ + + -- process Protocol Parameter Update Proposals -- NOT SURE WHAT IS GOING On HERE + _ppup' <- + trans @(Core.EraRule "PPUP" era) $ + TRC (PPUPEnv slot pp genDelegs, ppup, txUpdates txb) + + -- Check that the mint field does not try to mint ADA. This is equivalent to + -- the check `adaPolicy ∉ supp mint tx` in the spec. + Val.coin (getField @"mint" txb) == Val.zero ?! TriesToForgeADA + + let outputs = Map.elems $ unUTxO (txouts @era txb) + minUTxOValue = getField @"_minUTxOValue" pp + outputsTooSmall = + filter + ( \out -> + let v = getField @"value" out + in not $ + Val.pointwise + (>=) + v + (Val.inject $ scaledMinDeposit v minUTxOValue) + ) + outputs + null outputsTooSmall ?! OutputTooSmallUTxO outputsTooSmall + + let outputsTooBig = + filter + ( \out -> + let v = getField @"value" out + in (BSL.length . serialize) v > 4000 + -- TODO this is arbitrary, THERE IS SUPPOSEDLY A NEW + -- PParams files that holds this what is it? --TODO fix this + ) + outputs + null outputsTooBig ?! OutputTooBigUTxO outputsTooBig + + -- Bootstrap (i.e. Byron) addresses have variable sized attributes in them. + -- It is important to limit their overall size. + let outputsAttrsTooBig = + filter + ( \out -> case getField @"address" out of + AddrBootstrap addr -> bootstrapAddressAttrsSize addr > 64 + _ -> False + ) + outputs + null outputsAttrsTooBig ?! OutputBootAddrAttrsTooBig outputsAttrsTooBig + + let maxTxSize_ = fromIntegral (getField @"_maxTxSize" pp) + txSize_ = txsize tx + txSize_ <= maxTxSize_ ?! MaxTxSizeUTxO txSize_ maxTxSize_ + + let maxTxEx = getField @"_maxTxExUnits" pp + txExunits txb <= maxTxEx ?! ExUnitsTooSmallUTxO maxTxEx (txExunits txb) + + utxoS tx + +utxoS :: Tx era -> TransitionRule (AlonzoUTXO era) +utxoS _tx = undefined + +-------------------------------------------------------------------------------- +-- AlonzoUTXO STS +-------------------------------------------------------------------------------- + +instance + forall era. + ( Era era, + ValidateScript era, + Embed (Core.EraRule "PPUP" era) (AlonzoUTXO era), + Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era, + State (Core.EraRule "PPUP" era) ~ PPUPState era, + Signal (Core.EraRule "PPUP" era) ~ StrictMaybe (Update era), + -- We leave Core.PParams abstract + UsesPParams era, + HasField "_keyDeposit" (Core.PParams era) Coin, + HasField "_minfeeA" (Core.PParams era) Natural, + HasField "_minfeeB" (Core.PParams era) Natural, + HasField "_keyDeposit" (Core.PParams era) Coin, + HasField "_poolDeposit" (Core.PParams era) Coin, + HasField "_minUTxOValue" (Core.PParams era) Coin, + HasField "_maxTxSize" (Core.PParams era) Natural, + HasField "_prices" (Core.PParams era) Prices, + HasField "_maxTxExUnits" (Core.PParams era) ExUnits, + -- We fix Core.Value, Core.TxBody, and Core.TxOut + Core.Value era ~ Alonzo.Value (Crypto era), + Core.TxBody era ~ Alonzo.TxBody era, + Core.TxOut era ~ Alonzo.TxOut era + ) => + STS (AlonzoUTXO era) + where + type State (AlonzoUTXO era) = Shelley.UTxOState era + type Signal (AlonzoUTXO era) = Tx era + type + Environment (AlonzoUTXO era) = + Shelley.UtxoEnv era + type BaseM (AlonzoUTXO era) = ShelleyBase + type + PredicateFailure (AlonzoUTXO era) = + UtxoPredicateFailure era + + initialRules = [] + transitionRules = [utxoTransition] + +instance + ( Era era, + STS (PPUP era), + PredicateFailure (Core.EraRule "PPUP" era) ~ PpupPredicateFailure era + ) => + Embed (PPUP era) (AlonzoUTXO era) + where + wrapFailed = UpdateFailure + +-------------------------------------------------------------------------------- +-- Serialisation +-------------------------------------------------------------------------------- + +instance + ( Shelley.TransUTxOState ToCBOR era, + ToCBOR (PredicateFailure (Core.EraRule "PPUP" era)) + ) => + ToCBOR (UtxoPredicateFailure era) + where + toCBOR x = encode (encFail x) + +encFail :: + forall era. + ( Shelley.TransUTxOState ToCBOR era, + ToCBOR (PredicateFailure (Core.EraRule "PPUP" era)) + ) => + UtxoPredicateFailure era -> + Encode 'Open (UtxoPredicateFailure era) +encFail (BadInputsUTxO ins) = (Sum (BadInputsUTxO @era) 0 !> E encodeFoldable ins) +encFail (OutsideValidityIntervalUTxO a b) = (Sum OutsideValidityIntervalUTxO 1 !> To a !> To b) +encFail (MaxTxSizeUTxO a b) = (Sum MaxTxSizeUTxO 2 !> To a !> To b) +encFail (InputSetEmptyUTxO) = (Sum InputSetEmptyUTxO 3) +encFail (FeeTooSmallUTxO a b) = (Sum FeeTooSmallUTxO 4 !> To a !> To b) +encFail (ValueNotConservedUTxO a b) = (Sum (ValueNotConservedUTxO @era) 5 !> To a !> To b) +encFail (OutputTooSmallUTxO outs) = (Sum (OutputTooSmallUTxO @era) 6 !> E encodeFoldable outs) +encFail (UpdateFailure a) = (Sum (UpdateFailure @era) 7 !> To a) +encFail (WrongNetwork right wrongs) = (Sum (WrongNetwork @era) 8 !> To right !> E encodeFoldable wrongs) +encFail (WrongNetworkWithdrawal right wrongs) = (Sum (WrongNetworkWithdrawal @era) 9 !> To right !> E encodeFoldable wrongs) +encFail (OutputBootAddrAttrsTooBig outs) = (Sum (OutputBootAddrAttrsTooBig @era) 10 !> E encodeFoldable outs) +encFail (TriesToForgeADA) = (Sum TriesToForgeADA 11) +encFail (OutputTooBigUTxO outs) = (Sum (OutputTooBigUTxO @era) 12 !> E encodeFoldable outs) +encFail (FeeNotBalancedUTxO a b) = (Sum FeeNotBalancedUTxO 13 !> To a !> To b) +encFail (ScriptsNotPaidUTxO a) = (Sum ScriptsNotPaidUTxO 14 !> To a) +encFail (ExUnitsTooSmallUTxO a b) = (Sum ExUnitsTooSmallUTxO 15 !> To a !> To b) + +decFail :: + ( Shelley.TransUTxOState FromCBOR era, + FromCBOR (PredicateFailure (Core.EraRule "PPUP" era)) + ) => + Word -> + Decode 'Open (UtxoPredicateFailure era) +decFail 0 = SumD (BadInputsUTxO) + FromCBOR (UtxoPredicateFailure era) + where + fromCBOR = decode (Summands "UtxoPredicateFailure" decFail) diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs index 0039a18a7c3..88924700689 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs @@ -42,16 +42,19 @@ module Cardano.Ledger.Alonzo.Tx WitnessPPData, WitnessPPDataHash, -- Figure 3 - Tx (Tx, body, wits, isValidating, auxiliaryData), + Tx (Tx), + body, + wits, + isValidating, + auxiliaryData, TxBody (..), -- Figure 4 ScriptPurpose (..), -- Figure 5 getValidatorHash, txbody, - minfee, + txsize, isNonNativeScriptAddress, - feesOK, -- Figure 6 txrdmrs, rdptr, @@ -76,16 +79,20 @@ where import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Cardano.Ledger.Alonzo.Data (Data, DataHash, hashData) import Cardano.Ledger.Alonzo.Language (Language (..), nonNativeLanguages) -import Cardano.Ledger.Alonzo.PParams (LangDepView (..), PParams, PParams' (..), getLanguageView) -import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits (..), scriptfee) +import Cardano.Ledger.Alonzo.PParams (LangDepView (..), PParams, getLanguageView) +import Cardano.Ledger.Alonzo.Scripts (CostModel, ExUnits (..)) import qualified Cardano.Ledger.Alonzo.Scripts as AlonzoScript (Script (..), Tag (..)) import Cardano.Ledger.Alonzo.TxBody - ( AlonzoBody, - EraIndependentWitnessPPData, + ( EraIndependentWitnessPPData, TxBody (..), TxOut (..), WitnessPPDataHash, ppTxBody, + txcerts, + txinputs, + txinputs_fee, + txmint, + txwdrls, ) import Cardano.Ledger.Alonzo.TxWitness ( RdmrPtr (..), @@ -112,8 +119,7 @@ import Cardano.Ledger.SafeHash hashAnnotated, ) import Cardano.Ledger.Shelley.Constraints -import Cardano.Ledger.Val (DecodeMint, DecodeNonNegative, Val (coin, (<+>), (<×>))) -import Control.SetAlgebra (eval, (◁)) +import Cardano.Ledger.Val (DecodeMint, DecodeNonNegative, Val (coin)) import qualified Data.ByteString.Short as SBS (length) import Data.Coders import Data.List (foldl') @@ -143,7 +149,7 @@ import Shelley.Spec.Ledger.Delegation.Certificates (DCert (..)) import Shelley.Spec.Ledger.Scripts (ScriptHash) import Shelley.Spec.Ledger.Tx (ValidateScript (isNativeScript)) import Shelley.Spec.Ledger.TxBody (DelegCert (..), Delegation (..), TxIn (..), Wdrl (..), unWdrl) -import Shelley.Spec.Ledger.UTxO (UTxO (..), balance) +import Shelley.Spec.Ledger.UTxO (UTxO (..)) -- =================================================== @@ -193,6 +199,9 @@ instance newtype Tx era = TxConstr (MemoBytes (TxRaw era)) deriving newtype (ToCBOR) +instance HasField "_body" (Tx era) (TxBody era) where + getField (TxConstr (Memo x _)) = _body x + deriving newtype instance ( Era era, Eq (Core.AuxiliaryData era), @@ -229,7 +238,7 @@ pattern Tx :: IsValidating -> StrictMaybe (Core.AuxiliaryData era) -> Tx era -pattern Tx {body, wits, isValidating, auxiliaryData} <- +pattern Tx body wits isValidating auxiliaryData <- TxConstr ( Memo TxRaw @@ -243,6 +252,18 @@ pattern Tx {body, wits, isValidating, auxiliaryData} <- where Tx b w v a = TxConstr $ memoBytes (encodeTxRaw $ TxRaw b w v a) +body :: Tx era -> TxBody era +body (TxConstr (Memo (TxRaw b _ _ _) _)) = b + +wits :: Tx era -> TxWitness era +wits (TxConstr (Memo (TxRaw _ x _ _) _)) = x + +isValidating :: Tx era -> IsValidating +isValidating (TxConstr (Memo (TxRaw _ _ x _) _)) = x + +auxiliaryData :: Tx era -> StrictMaybe (Core.AuxiliaryData era) +auxiliaryData (TxConstr (Memo (TxRaw _ _ _ x) _)) = x + -------------------------------------------------------------------------------- -- Serialisation -------------------------------------------------------------------------------- @@ -394,44 +415,14 @@ isNonNativeScriptAddress (TxConstr (Memo (TxRaw {_wits = w}) _)) addr = Nothing -> False Just scr -> not (isNativeScript @era scr) -feesOK :: - forall era. - ( UsesValue era, - AlonzoBody era, - UsesTxOut era, - ValidateScript era - ) => - PParams era -> - Tx era -> - UTxO era -> - Bool -feesOK pp tx (UTxO m) = - (bal >= txfee txb) - && (all (\txout -> not (isNonNativeScriptAddress tx (getField @"address" txout))) utxoFees) - && (minfee pp tx <= txfee txb) - where - txb = txbody tx - fees = txinputs_fee txb - utxoFees = eval (fees ◁ m) -- compute the domain restriction to those inputs where fees are paid - bal = coin (balance @era (UTxO utxoFees)) - -- | The keys of all the inputs of the TxBody (both the inputs for fees, and the normal inputs). -txins :: AlonzoBody era => TxBody era -> Set (TxIn (Crypto era)) -txins (TxBody {txinputs = is, txinputs_fee = fs}) = Set.union is fs +txins :: TxBody era -> Set (TxIn (Crypto era)) +txins b = Set.union (txinputs b) (txinputs_fee b) -- | txsize computes the length of the serialised bytes txsize :: Tx era -> Integer txsize (TxConstr (Memo _ bytes)) = fromIntegral (SBS.length bytes) -minfee :: AlonzoBody era => PParams era -> Tx era -> Coin -minfee pp tx = - ((txsize tx) <×> (a pp)) - <+> (b pp) - <+> (scriptfee (_prices pp) (exunits (txbody tx))) - where - a protparam = Coin (fromIntegral (_minfeeA protparam)) - b protparam = Coin (fromIntegral (_minfeeB protparam)) - -- The specification uses "validatorHash" to extract ScriptHash from -- an Addr. But not every Addr has a ScriptHash. In particular KeyHashObj -- do not. So we use getValidatorHash which returns a Maybe type. @@ -476,11 +467,10 @@ instance Ord k => Indexable k (Map.Map k v) where atIndex i mp = fst (Map.elemAt (fromIntegral i) mp) -- If one needs the value, on can use Map.Lookup rdptr :: - AlonzoBody era => TxBody era -> ScriptPurpose (Crypto era) -> RdmrPtr -rdptr txb (Minting pid) = RdmrPtr AlonzoScript.Mint (indexOf pid (getMapFromValue (mint txb))) +rdptr txb (Minting pid) = RdmrPtr AlonzoScript.Mint (indexOf pid (getMapFromValue (txmint txb))) rdptr txb (Spending txin) = RdmrPtr AlonzoScript.Spend (indexOf txin (txinputs txb)) rdptr txb (Rewarding racnt) = RdmrPtr AlonzoScript.Rewrd (indexOf racnt (unWdrl (txwdrls txb))) rdptr txb (Certifying d) = RdmrPtr AlonzoScript.Cert (indexOf d (txcerts txb)) @@ -490,10 +480,7 @@ getMapFromValue (Value _ m) = m indexedRdmrs :: ( Era era, - ToCBOR (Core.AuxiliaryData era), - ToCBOR (Core.Script era), - Core.SerialisableData (PParamsDelta era), - Compactible (Core.Value era) + ToCBOR (Core.Script era) ) => Tx era -> ScriptPurpose (Crypto era) -> @@ -529,8 +516,7 @@ runPLCScript _cost _script _data _exunits = (IsValidating True, ExUnits 0 0) -- getData :: forall era. - ( ToCBOR (Core.AuxiliaryData era), - ToCBOR (Core.Script era), + ( ToCBOR (Core.Script era), UsesTxOut era, HasField "datahash" (Core.TxOut era) (Maybe (DataHash (Crypto era))) ) => @@ -556,10 +542,6 @@ getData tx (UTxO m) sp = case sp of collectNNScriptInputs :: ( UsesTxOut era, - ToCBOR (Core.Script era), - Compactible (Core.Value era), - ToCBOR (Core.AuxiliaryData era), - Core.SerialisableData (PParamsDelta era), Core.Script era ~ AlonzoScript.Script era, HasField "datahash" (Core.TxOut era) (Maybe (DataHash (Crypto era))), HasField "_costmdls" (Core.PParams era) (Map.Map Language CostModel) @@ -594,8 +576,7 @@ evalScripts (AlonzoScript.PlutusScript, ds, units, cost) = b -- THE SPEC CALLS FOR A SET, BUT THAT NEEDS A BUNCH OF ORD INSTANCES (DCert) scriptsNeeded :: forall era. - ( UsesTxOut era, - AlonzoBody era + ( UsesTxOut era ) => UTxO era -> Tx era -> @@ -624,7 +605,7 @@ scriptsNeeded (UTxO utxomap) tx = spend ++ reward ++ cert ++ minted !minted = map (\pid@(PolicyID hash) -> (Minting pid, hash)) (Map.keys m3) where - m3 = getMapFromValue (mint txb) + m3 = getMapFromValue (txmint txb) -- We only find certificate witnesses in Delegating and Deregistration DCerts -- that have ScriptHashObj credentials. @@ -640,10 +621,7 @@ addOnlyCwitness !ans _ = ans checkScriptData :: forall era. - ( ToCBOR (Core.AuxiliaryData era), - Core.SerialisableData (PParamsDelta era), - ValidateScript era, - Compactible (Core.Value era), + ( ValidateScript era, UsesTxOut era, HasField "datahash" (Core.TxOut era) (Maybe (DataHash (Crypto era))) ) => @@ -662,7 +640,7 @@ checkScriptData tx utxo (sp, _h) = any ok scripts && (not (isSpending sp) || not (null (getData tx utxo sp))) ) -txwits :: (Era era, ToCBOR (Core.AuxiliaryData era)) => Tx era -> TxWitness era +txwits :: Tx era -> TxWitness era txwits x = wits x -- ======================================================= diff --git a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs index fdf6848ccdc..34f2855b775 100644 --- a/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs +++ b/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs @@ -19,22 +19,21 @@ module Cardano.Ledger.Alonzo.TxBody ( TxOut (TxOut, TxOutCompact), - TxBody - ( TxBody, - txinputs, - txinputs_fee, - txouts, - txcerts, - txwdrls, - txfee, - txvldt, - txUpdates, - txADhash, - mint, - exunits, - sdHash, - scriptHash - ), + TxBody (TxBody), + txinputs, + txinputs_fee, + txouts, + txcerts, + txwdrls, + txfee, + txvldt, + txUpdates, + txADhash, + txmint, + txExunits, + txsdHash, + txscriptHash, + TransTxBody, AlonzoBody, EraIndependentWitnessPPData, WitnessPPDataHash, @@ -74,7 +73,7 @@ import Cardano.Ledger.SafeHash SafeHash, SafeToHash, ) -import Cardano.Ledger.Shelley.Constraints (PParamsDelta) +import Cardano.Ledger.Shelley.Constraints (PParamsDelta, TransValue) import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..), ppValidityInterval) import Cardano.Ledger.Val ( DecodeNonNegative, @@ -179,6 +178,8 @@ deriving instance ) => Eq (TxBodyRaw era) +type TransTxBody p era = (TransValue p era, p (PParamsDelta era)) + instance (Typeable era, NoThunks (Core.Value era), NoThunks (PParamsDelta era)) => NoThunks (TxBodyRaw era) @@ -253,20 +254,19 @@ pattern TxBody :: StrictMaybe (AuxiliaryDataHash (Crypto era)) -> TxBody era pattern TxBody - { txinputs, - txinputs_fee, - txouts, - txcerts, - txwdrls, - txfee, - txvldt, - txUpdates, - txADhash, - mint, - exunits, - sdHash, - scriptHash - } <- + txinputs + txinputs_fee + txouts + txcerts + txwdrls + txfee + txvldt + txUpdates + txADhash + mint + exunits + sdHash + scriptHash <- TxBodyConstr ( Memo TxBodyRaw @@ -324,6 +324,50 @@ pattern TxBody instance (c ~ Crypto era, Era era) => HashAnnotated (TxBody era) EraIndependentTxBody c +-- We define these accessor functions manually, because if we define them using +-- the record syntax in the TxBody pattern, they inherit the (AlonzoBody era) +-- constraint as a precondition. This is unnecessary, as one can see below +-- they need not be constrained at all. This should be fixed in the GHC compiler. + +txinputs :: TxBody era -> Set (TxIn (Crypto era)) +txinputs_fee :: TxBody era -> Set (TxIn (Crypto era)) +txouts :: TxBody era -> StrictSeq (TxOut era) +txcerts :: TxBody era -> StrictSeq (DCert (Crypto era)) +txfee :: TxBody era -> Coin +txwdrls :: TxBody era -> Wdrl (Crypto era) +txvldt :: TxBody era -> ValidityInterval +txUpdates :: TxBody era -> StrictMaybe (Update era) +txADhash :: TxBody era -> StrictMaybe (AuxiliaryDataHash (Crypto era)) +txmint :: TxBody era -> Value (Crypto era) +txExunits :: TxBody era -> ExUnits +txsdHash :: TxBody era -> StrictMaybe (WitnessPPDataHash (Crypto era)) +txscriptHash :: TxBody era -> StrictMaybe (AuxiliaryDataHash (Crypto era)) +txinputs (TxBodyConstr (Memo raw _)) = _inputs raw + +txinputs_fee (TxBodyConstr (Memo raw _)) = _inputs_fee raw + +txouts (TxBodyConstr (Memo raw _)) = _outputs raw + +txcerts (TxBodyConstr (Memo raw _)) = _certs raw + +txwdrls (TxBodyConstr (Memo raw _)) = _wdrls raw + +txfee (TxBodyConstr (Memo raw _)) = _txfee raw + +txvldt (TxBodyConstr (Memo raw _)) = _vldt raw + +txUpdates (TxBodyConstr (Memo raw _)) = _update raw + +txADhash (TxBodyConstr (Memo raw _)) = _adHash raw + +txmint (TxBodyConstr (Memo raw _)) = _mint raw + +txExunits (TxBodyConstr (Memo raw _)) = _exunits raw + +txsdHash (TxBodyConstr (Memo raw _)) = _sdHash raw + +txscriptHash (TxBodyConstr (Memo raw _)) = _scriptHash raw + -------------------------------------------------------------------------------- -- Serialisation -------------------------------------------------------------------------------- @@ -519,9 +563,15 @@ instance Crypto era ~ crypto => HasField "wdrls" (TxBody era) (Wdrl crypto) wher instance HasField "txfee" (TxBody era) Coin where getField (TxBodyConstr (Memo m _)) = _txfee m +instance Crypto era ~ crypto => HasField "mint" (TxBody era) (Value crypto) where + getField (TxBodyConstr (Memo m _)) = _mint m + instance HasField "update" (TxBody era) (StrictMaybe (Update era)) where getField (TxBodyConstr (Memo m _)) = _update m +instance HasField "vldt" (TxBody era) (ValidityInterval) where + getField (TxBodyConstr (Memo m _)) = _vldt m + instance (Crypto era ~ c) => HasField "compactAddress" (TxOut era) (CompactAddr c) where getField (TxOutCompact a _ _) = a diff --git a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxo.hs b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxo.hs index 41450bf75fe..511d7d2ec41 100644 --- a/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxo.hs +++ b/shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxo.hs @@ -29,6 +29,7 @@ import Cardano.Ledger.Shelley.Constraints ) import Cardano.Ledger.ShelleyMA.Timelocks import Cardano.Ledger.ShelleyMA.TxBody (TxBody) +import Cardano.Ledger.Val ((<+>)) import qualified Cardano.Ledger.Val as Val import Cardano.Prelude (heapWordsUnpacked) import Cardano.Slotting.Slot (SlotNo) @@ -199,8 +200,8 @@ instance -- the mint field. consumed :: forall era. - ( UsesValue era, - UsesTxOut era, + ( Val.Val (Core.Value era), + HasField "value" (Core.TxOut era) (Core.Value era), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))), HasField "mint" (Core.TxBody era) (Core.Value era), @@ -213,8 +214,8 @@ consumed :: Core.Value era consumed pp u tx = balance @era (eval (txins @era tx ◁ u)) - <> getField @"mint" tx - <> (Val.inject $ refunds <> withdrawals) + <+> getField @"mint" tx + <+> (Val.inject $ refunds <+> withdrawals) where -- balance (UTxO (Map.restrictKeys v (txins tx))) + refunds + withdrawals refunds = Shelley.keyRefunds pp tx 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 bbc7b4e6927..67df6b73819 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 @@ -110,7 +110,7 @@ import Cardano.Ledger.Compactible import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CC (Crypto) import Cardano.Ledger.Era (Crypto, Era) -import Cardano.Ledger.SafeHash (extractHash, hashAnnotated) +import Cardano.Ledger.SafeHash (HashAnnotated, extractHash, hashAnnotated) import Cardano.Ledger.Shelley.Constraints ( TransValue, UsesAuxiliary, @@ -763,9 +763,10 @@ minfee pp tx = -- | Compute the lovelace which are created by the transaction produced :: forall era pp. - ( UsesTxBody era, - UsesValue era, - UsesTxOut era, + ( Era era, + HashAnnotated (Core.TxBody era) EraIndependentTxBody (Crypto era), -- due to txouts + Val.Val (Core.Value era), -- due to <+> + HasField "value" (Core.TxOut era) (Core.Value era), HasField "certs" (Core.TxBody era) (StrictSeq (DCert (Crypto era))), HasField "outputs" (Core.TxBody era) (StrictSeq (Core.TxOut era)), HasField "txfee" (Core.TxBody era) Coin, 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 c586ff5c5b2..9bdd7871134 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 @@ -51,9 +51,9 @@ import qualified Cardano.Crypto.Hash as CH import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Crypto as CC (Crypto, HASH) import Cardano.Ledger.Era -import Cardano.Ledger.SafeHash (SafeHash, extractHash, hashAnnotated) -import Cardano.Ledger.Shelley.Constraints (UsesTxBody, UsesTxOut, UsesValue) -import Cardano.Ledger.Val ((<+>), (<×>)) +import Cardano.Ledger.SafeHash (HashAnnotated, SafeHash, extractHash, hashAnnotated) +import Cardano.Ledger.Shelley.Constraints (UsesTxOut) +import Cardano.Ledger.Val (Val (..), (<+>), (<×>)) import Control.DeepSeq (NFData) import Control.Iterate.SetAlgebra ( BaseRep (MapR), @@ -161,7 +161,12 @@ deriving via -- | Compute the id of a transaction. txid :: forall era. - UsesTxBody era => + ( Era era, -- The Crypto functions are determined + HashAnnotated -- Core.TxBody hashes with the right tag: EraIndependentTxBody + (Core.TxBody era) + EraIndependentTxBody + (Crypto era) + ) => Core.TxBody era -> TxId (Crypto era) txid = TxId . hashAnnotated @@ -184,7 +189,8 @@ txins = getField @"inputs" -- | Compute the transaction outputs of a transaction. txouts :: forall era. - ( UsesTxBody era, + ( Era era, + HashAnnotated (Core.TxBody era) EraIndependentTxBody (Crypto era), HasField "outputs" (Core.TxBody era) (StrictSeq (Core.TxOut era)) ) => Core.TxBody era -> @@ -255,8 +261,8 @@ makeWitnessesFromScriptKeys txbodyHash hashKeyMap scriptHashes = -- | Determine the total balance contained in the UTxO. balance :: - ( UsesValue era, - UsesTxOut era + ( Val (Core.Value era), + HasField "value" (Core.TxOut era) (Core.Value era) ) => UTxO era -> Core.Value era