on the protocol version, namely: don't resolve pointer addresses for Conway era and later
let refunded = keyTxRefunds pp dpstate txb
let depositChange = totalTxDeposits pp dpstate txb Val.<-> refunded
pure $! Shelley.updateUTxOState u txb depositChange ppup'
pure $! Shelley.updateUTxOState pp u txb depositChange ppup'
-- | Ensure the transaction is within the validity window.
--
TRC
(PPUPEnv slot pp genDelegs, pup, strictMaybeToMaybe $ txBody ^. updateTxBodyL)
pure $! updateUTxOState u txBody depositChange ppup'
pure $! updateUTxOState pp u txBody depositChange ppup'
scriptsNotValidateTransition ::
forall era.
us
{ utxosUtxo = UTxO utxoKeep
, utxosFees = fees <> coinBalance (UTxO utxoDel)
, utxosStakeDistr = updateStakeDistribution (utxosStakeDistr us) (UTxO utxoDel) mempty
, utxosStakeDistr = updateStakeDistribution pp (utxosStakeDistr us) (UTxO utxoDel) mempty
}
-- =======================================
let !_ = traceEvent validEnd ()
pure $! updateUTxOState u txBody depositChange ppup'
pure $! updateUTxOState pp u txBody depositChange ppup'
scriptsNo ::
forall era.
{ utxosUtxo = UTxO (Map.union utxoKeep collouts) -- NEW to Babbage
{- fees + collateralFees -}
, utxosFees = fees <> collateralFees -- NEW to Babbage
, utxosStakeDistr = updateStakeDistribution (utxosStakeDistr us) (UTxO utxoDel) (UTxO collouts)
, utxosStakeDistr = updateStakeDistribution pp (utxosStakeDistr us) (UTxO utxoDel) (UTxO collouts)
}
Assertion
testMaryNoDelegLEDGER utxo tx env (Right expectedUTxO) = do
checkTrace @(ShelleyLEDGER Mary) runShelleyBase env $
pure (LedgerState (smartUTxOState utxo (Coin 0) (Coin 0) def) def emptyTallyState) .- tx .->> expectedSt'
pure (LedgerState (smartUTxOState (ledgerPp env) utxo (Coin 0) (Coin 0) def) def emptyTallyState) .- tx .->> expectedSt'
where
txFee = tx ^. bodyTxL . feeTxBodyL
expectedSt' = LedgerState (smartUTxOState expectedUTxO (Coin 0) txFee def) def emptyTallyState
expectedSt' = LedgerState (smartUTxOState (ledgerPp env) expectedUTxO (Coin 0) txFee def) def emptyTallyState
testMaryNoDelegLEDGER utxo tx env [email protected](Left _) = do
let st =
runShelleyBase $
applySTSTest @(ShelleyLEDGER Mary)
( TRC
( env
, LedgerState (smartUTxOState utxo (Coin 0) (Coin 0) def) def emptyTallyState
, LedgerState (smartUTxOState (ledgerPp env) utxo (Coin 0) (Coin 0) def) def emptyTallyState
, tx
)
)
(AccountState (Coin 0) reserves)
emptySnapShots
( LedgerState
(smartUTxOState initialUtxo (Coin 0) (Coin 0) def)
(smartUTxOState (fromShelleyPParams ag pp) initialUtxo (Coin 0) (Coin 0) def)
(DPState (def {dsGenDelegs = GenDelegs genDelegs}) def)
emptyTallyState
)
-- | Incrementally add the inserts 'utxoAdd' and the deletes 'utxoDel' to the IncrementalStake.
updateStakeDistribution ::
EraTxOut era =>
PParams era ->
IncrementalStake (EraCrypto era) ->
UTxO era ->
UTxO era ->
IncrementalStake (EraCrypto era)
updateStakeDistribution incStake0 utxoDel utxoAdd = incStake2
updateStakeDistribution pp incStake0 utxoDel utxoAdd = incStake2
where
incStake1 = incrementalAggregateUtxoCoinByCredential id utxoAdd incStake0
incStake2 = incrementalAggregateUtxoCoinByCredential invert utxoDel incStake1
incStake1 = incrementalAggregateUtxoCoinByCredential pp id utxoAdd incStake0
incStake2 = incrementalAggregateUtxoCoinByCredential pp invert utxoDel incStake1
-- | Incrementally sum up all the Coin, for each staking Credential, in the outputs of the UTxO, and
-- "add" them to the IncrementalStake. "add" has different meaning depending on if we are inserting
incrementalAggregateUtxoCoinByCredential ::
forall era.
EraTxOut era =>
PParams era ->
(Coin -> Coin) ->
UTxO era ->
IncrementalStake (EraCrypto era) ->
IncrementalStake (EraCrypto era)
incrementalAggregateUtxoCoinByCredential mode (UTxO u) initial =
incrementalAggregateUtxoCoinByCredential pp mode (UTxO u) initial =
Map.foldl' accum initial u
where
keepOrDelete new Nothing =
case mode new <> old of
Coin 0 -> Nothing
final -> Just final
ignorePtrs = HardForks.forgoPointerAddressResolution (pp ^. ppProtocolVersionL)
accum [email protected](IStake stake ptrs) out =
let c = out ^. coinTxOutL
in case out ^. addrTxOutL of
Addr _ _ (StakeRefPtr p) -> IStake stake (Map.alter (keepOrDelete c) p ptrs)
Addr _ _ (StakeRefPtr p) ->
if ignorePtrs
then ans
else IStake stake (Map.alter (keepOrDelete c) p ptrs)
Addr _ _ (StakeRefBase hk) -> IStake (Map.alter (keepOrDelete c) hk stake) ptrs
_other -> ans
--
-- TO IncrementalStake
smartUTxOState ::
( EraTxOut era
) =>
EraTxOut era =>
PParams era ->
UTxO era ->
Coin ->
Coin ->
PPUPState era ->
UTxOState era
smartUTxOState utxo c1 c2 st =
smartUTxOState pp utxo c1 c2 st =
UTxOState
utxo
c1
c2
st
(updateStakeDistribution mempty mempty utxo)
(updateStakeDistribution pp mempty mempty utxo)
-- =======================================================================
-- Part 2. Compute a Snapshot using the IncrementalStake in Snap rule
let totalDeposits' = totalTxDeposits pp dpstate txb
let depositChange = totalDeposits' Val.<-> refunded
tellEvent $ TotalDeposits (hashAnnotated txb) depositChange
pure $! updateUTxOState u txb depositChange ppup'
pure $! updateUTxOState pp u txb depositChange ppup'
-- | The ttl field marks the top of an open interval, so it must be strictly
-- less than the slot, so fail if it is (>=).
updateUTxOState ::
(EraTxBody era, PPUPState era ~ ShelleyPPUPState era) =>
PParams era ->
UTxOState era ->
TxBody era ->
Coin ->
ShelleyPPUPState era ->
UTxOState era
updateUTxOState UTxOState {utxosUtxo, utxosDeposited, utxosFees, utxosStakeDistr} txb depositChange ppups =
updateUTxOState pp UTxOState {utxosUtxo, utxosDeposited, utxosFees, utxosStakeDistr} txb depositChange ppups =
let UTxO utxo = utxosUtxo
!utxoAdd = txouts txb -- These will be inserted into the UTxO
{- utxoDel = txins txb ◁ utxo -}
!(utxoWithout, utxoDel) = extractKeys utxo (txb ^. inputsTxBodyL)
{- newUTxO = (txins txb ⋪ utxo) ∪ outs txb -}
newUTxO = utxoWithout `Map.union` unUTxO utxoAdd
newIncStakeDistro = updateStakeDistribution utxosStakeDistr (UTxO utxoDel) utxoAdd
newIncStakeDistro = updateStakeDistribution pp utxosStakeDistr (UTxO utxoDel) utxoAdd
in UTxOState
{ utxosUtxo = UTxO newUTxO
, utxosDeposited = utxosDeposited <> depositChange
("UTxO=" ++ show x ++ ", address=" ++ show n)
[ bench "stakeDistr" (nf action2m arg)
, bench "incrementalStakeDistr" (nf action2im arg)
, env (pure (updateStakeDistribution mempty mempty utxo)) $ \incStake ->
, env (pure (updateStakeDistribution def mempty mempty utxo)) $ \incStake ->
bench "incrementalStakeDistr (no update)" $
nf (\d -> incrementalStakeDistr (def :: PParams Shelley) incStake dstate d) pstate
]
(DState (EraCrypto era), PState (EraCrypto era), UTxO era) ->
EB.SnapShot (EraCrypto era)
action2im (dstate, pstate, utxo) =
let incStake = updateStakeDistribution mempty mempty utxo
in incrementalStakeDistr (def :: PParams era) incStake dstate pstate
let pp = def :: PParams era
incStake = updateStakeDistribution pp mempty mempty utxo
in incrementalStakeDistr pp incStake dstate pstate
-- =================================================================
-Wincomplete-uni-patterns
-Wredundant-constraints
-Wunused-packages
-fprint-potential-instances
library
import: base, project-config
-- The 4 megabytes stack bound and 250 megabytes heap bound were
-- determined ad-hoc.
"-with-rtsopts=-K4m -M250m"
-fprint-potential-instances
build-depends:
QuickCheck,
aeson >= 2,
emptySnapShots
( LedgerState
( smartUTxOState
pp
utxo
(Coin 0)
(Coin 0)
utxoWithout = Map.withoutKeys utxo (txins @era txb)
utxoDel = UTxO utxoToDel
utxo' = UTxO (utxoWithout `Map.union` unUTxO utxoAdd)
sd' = updateStakeDistribution @era (utxosStakeDistr utxoSt) utxoDel utxoAdd
sd' = updateStakeDistribution @era (esPp es) (utxosStakeDistr utxoSt) utxoDel utxoAdd
utxoSt' = utxoSt {utxosUtxo = utxo', utxosStakeDistr = sd'}
ls' = ls {lsUTxOState = utxoSt'}
es' = es {esLState = ls'}
initialBBodyState pf utxo =
BbodyState (LedgerState initialUtxoSt dpstate emptyTallyState) (BlocksMade mempty)
where
initialUtxoSt = smartUTxOState utxo (UM.fromCompact successDeposit) (Coin 0) def
initialUtxoSt = smartUTxOState (pp pf) utxo (UM.fromCompact successDeposit) (Coin 0) def
dpstate =
def
{ dpsDState =
, DHash' [hashData $ someDatum @era]
]
poolID = hashKey . vKey . coerceKeyRole $ coldKeys
example1UtxoSt = smartUTxOState utxo totalDeposits (Coin 40) def
example1UtxoSt = smartUTxOState (pp pf) utxo totalDeposits (Coin 40) def
-- the default DPState 'def' means that the 'totalDeposits' must be 0
totalDeposits = (Coin 0)
in BbodyState
) =>
Proof era ->
UTxOState era
validatingState pf = smartUTxOState utxo (Coin 0) (Coin 5) def
validatingState pf = smartUTxOState (pp pf) utxo (Coin 0) (Coin 5) def
where
utxo = expectedUTxO' pf (ExpectSuccess (validatingBody pf) (validatingTxOut pf)) 1
) =>
Proof era ->
UTxOState era
notValidatingState pf = smartUTxOState (expectedUTxO' pf ExpectFailure 2) (Coin 0) (Coin 5) def
notValidatingState pf = smartUTxOState (pp pf) (expectedUTxO' pf ExpectFailure 2) (Coin 0) (Coin 5) def
-- =========================================================================
-- Example 3: Process a CERT transaction with a succeeding Plutus script.
) =>
Proof era ->
UTxOState era
validatingWithCertState pf = smartUTxOState utxo (Coin 0) (Coin 5) def
validatingWithCertState pf = smartUTxOState (pp pf) utxo (Coin 0) (Coin 5) def
where
utxo = expectedUTxO' pf (ExpectSuccess (validatingWithCertBody pf) (validatingWithCertTxOut pf)) 3
) =>
Proof era ->
UTxOState era
notValidatingWithCertState pf = smartUTxOState (expectedUTxO' pf ExpectFailure 4) (Coin 0) (Coin 5) def
notValidatingWithCertState pf = smartUTxOState (pp pf) (expectedUTxO' pf ExpectFailure 4) (Coin 0) (Coin 5) def
-- ==============================================================================
-- Example 5: Process a WITHDRAWAL transaction with a succeeding Plutus script.
(EraTxBody era, PostShelley era, Default (PPUPState era)) =>
Proof era ->
UTxOState era
validatingWithWithdrawalState pf = smartUTxOState utxo (Coin 0) (Coin 5) def
validatingWithWithdrawalState pf = smartUTxOState (pp pf) utxo (Coin 0) (Coin 5) def
where
utxo = expectedUTxO' pf (ExpectSuccess (validatingWithWithdrawalBody pf) (validatingWithWithdrawalTxOut pf)) 5
(EraTxBody era, PostShelley era, Default (PPUPState era)) =>
Proof era ->
UTxOState era
notValidatingWithWithdrawalState pf = smartUTxOState (expectedUTxO' pf ExpectFailure 6) (Coin 0) (Coin 5) def
notValidatingWithWithdrawalState pf = smartUTxOState (pp pf) (expectedUTxO' pf ExpectFailure 6) (Coin 0) (Coin 5) def
-- =============================================================================
-- Example 7: Process a MINT transaction with a succeeding Plutus script.
(PostShelley era, EraTxBody era, HasTokens era, Value era ~ MaryValue (EraCrypto era), Default (PPUPState era)) =>
Proof era ->
UTxOState era
validatingWithMintState pf = smartUTxOState utxo (Coin 0) (Coin 5) def
validatingWithMintState pf = smartUTxOState (pp pf) utxo (Coin 0) (Coin 5) def
where
utxo = expectedUTxO' pf (ExpectSuccess (validatingWithMintBody pf) (validatingWithMintTxOut pf)) 7
(EraTxBody era, PostShelley era, Default (PPUPState era)) =>
Proof era ->
UTxOState era
notValidatingWithMintState pf = smartUTxOState utxo (Coin 0) (Coin 5) def
notValidatingWithMintState pf = smartUTxOState (pp pf) utxo (Coin 0) (Coin 5) def
where
utxo = expectedUTxO' pf ExpectFailure 8
(EraTxBody era, PostShelley era, HasTokens era, Value era ~ MaryValue (EraCrypto era), Default (PPUPState era)) =>
Proof era ->
UTxOState era
validatingManyScriptsState pf = smartUTxOState (UTxO utxo) (Coin 0) (Coin 5) def
validatingManyScriptsState pf = smartUTxOState (pp pf) (UTxO utxo) (Coin 0) (Coin 5) def
where
utxo =
Map.insert (TxIn (txid (validatingManyScriptsBody pf)) minBound) (validatingManyScriptsTxOut pf) $
(EraTxBody era, PostShelley era, Default (PPUPState era)) =>
Proof era ->
UTxOState era
validatingSupplimentaryDatumState pf = smartUTxOState utxo (Coin 0) (Coin 5) def
validatingSupplimentaryDatumState pf = smartUTxOState (pp pf) utxo (Coin 0) (Coin 5) def
where
utxo = expectedUTxO' pf (ExpectSuccess (validatingSupplimentaryDatumBody pf) (validatingSupplimentaryDatumTxOut pf)) 3
(EraTxBody era, PostShelley era, Default (PPUPState era)) =>
Proof era ->
UTxOState era
validatingMultipleEqualCertsState pf = smartUTxOState utxo (Coin 0) (Coin 5) def
validatingMultipleEqualCertsState pf = smartUTxOState (pp pf) utxo (Coin 0) (Coin 5) def
where
utxo = expectedUTxO' pf (ExpectSuccess (validatingMultipleEqualCertsBody pf) (validatingMultipleEqualCertsOut pf)) 3
) =>
Proof era ->
UTxOState era
validatingNonScriptOutWithDatumState pf = smartUTxOState utxo (Coin 0) (Coin 5) def
validatingNonScriptOutWithDatumState pf = smartUTxOState (pp pf) utxo (Coin 0) (Coin 5) def
where
utxo = expectedUTxO' pf (ExpectSuccess (validatingNonScriptOutWithDatumTxBody pf) (validatingNonScriptOutWithDatumTxOut pf)) 103
initUtxo = (UTxO . Map.fromList) $ inputs' ++ refInputs' ++ collateral'
expectedUtxo = UTxO $ Map.fromList (newTxInOut ++ refInputs' ++ collateral')
expectedState = smartUTxOState expectedUtxo (Coin 0) fees def
expectedState = smartUTxOState (pp pf) expectedUtxo (Coin 0) fees def
assumedValidTx = trustMeP pf True tx'
in testUTXOW (UTXOW pf) initUtxo (pp pf) assumedValidTx (Right expectedState)
initUtxo = UTxO . Map.fromList $ inputs' ++ refInputs' ++ collateral'
colBallance = Collateral.collAdaBalance txBody' (Map.fromList collateral')
expectedUtxo = UTxO $ Map.fromList (inputs' ++ refInputs' ++ newColReturn txBody')
expectedState = smartUTxOState expectedUtxo (Coin 0) colBallance def
expectedState = smartUTxOState (pp pf) expectedUtxo (Coin 0) colBallance def
assumedInvalidTx = trustMeP pf False tx'
in testUTXOW (UTXOW pf) initUtxo (pp pf) assumedInvalidTx (Right expectedState)
-- | Use a test where any two (ValidationTagMismatch x y) failures match regardless of 'x' and 'y'
testUTXOspecialCase [email protected](UTXOW proof) utxo pparam tx expected =
let env = UtxoEnv (SlotNo 0) pparam def (GenDelegs mempty)
state = smartUTxOState utxo (Coin 0) (Coin 0) def
state = smartUTxOState pparam utxo (Coin 0) (Coin 0) def
in case proof of
Alonzo _ -> runSTS wit (TRC (env, state, tx)) (specialCont proof expected)
Babbage _ -> runSTS wit (TRC (env, state, tx)) (specialCont proof expected)
Assertion
testUTXOWwith [email protected](UTXOW proof) cont utxo pparams tx expected =
let env = UtxoEnv (SlotNo 0) pparams def (GenDelegs mempty)
state = smartUTxOState utxo (Coin 0) (Coin 0) def
state = smartUTxOState pparams utxo (Coin 0) (Coin 0) def
in case proof of
Conway _ -> runSTS wit (TRC (env, state, tx)) (cont expected)
Babbage _ -> runSTS wit (TRC (env, state, tx)) (cont expected)
initialLedgerState gstate = LedgerState utxostate dpstate emptyTallyState
where
umap = UM.unify (Map.map rdpair (gsInitialRewards gstate)) (gsInitialDelegations gstate) Map.empty
utxostate = smartUTxOState (UTxO (gsInitialUtxo gstate)) deposited (Coin 0) (ppupStateZero @era)
utxostate = smartUTxOState pp (UTxO (gsInitialUtxo gstate)) deposited (Coin 0) (ppupStateZero @era)
dpstate = DPState dstate pstate
dstate =
DState
ppupStateZero = ppupStateZeroByProof @era (reify :: Proof era)
uTxOStateZero :: forall era. Reflect era => UTxOState era
uTxOStateZero = smartUTxOState utxoZero mempty mempty (ppupStateZero @era)
uTxOStateZero = smartUTxOState pParamsZero utxoZero mempty mempty (ppupStateZero @era)
pParamsZero :: Reflect era => Core.PParams era
pParamsZero = lift pParamsZeroByProof
instance Reflect era => Extract (UTxOState era) era where
extract x =
smartUTxOState
(mPParams x)
(UTxO (mUTxO x))
(mDeposited x)
(mFees x)
stakeInvariant :: EraTxOut era => MockChainState era -> MockChainState era -> Property
stakeInvariant (MockChainState _ _ _) (MockChainState nes _ _) =
case (lsUTxOState . esLState . nesEs) nes of
(UTxOState utxo _ _ _ istake) -> istake === updateStakeDistribution mempty mempty utxo
(UTxOState utxo _ _ _ istake) -> istake === updateStakeDistribution def mempty mempty utxo
incrementStakeInvariant ::
( Reflect era
, cardano-ledger-shelley
, conduit
, containers
, data-default-class
, vector-map
, deepseq
, foldl
import Cardano.Ledger.Alonzo.TxBody as Alonzo
import Cardano.Ledger.Binary
import Cardano.Ledger.Core (PParams)
import qualified Cardano.Ledger.Credential as Credential
import qualified Cardano.Ledger.EpochBoundary as EpochBoundary
import qualified Cardano.Ledger.Keys as Keys
import Control.Monad.Trans.Reader
import Data.Conduit.Internal (zipSources)
import Data.Conduit.List (sourceList)
import Data.Default.Class (def)
import Data.Functor
import qualified Data.IntMap.Strict as IntMap
import qualified Data.Map.Strict as Map
pure
Shelley.LedgerState
{ Shelley.lsUTxOState =
Shelley.smartUTxOState utxo utxoStateDeposited utxoStateFees utxoStatePpups -- Maintain invariant
Shelley.smartUTxOState (def :: PParams CurrentEra) utxo utxoStateDeposited utxoStateFees utxoStatePpups -- Maintain invariant
, Shelley.lsDPState =
Shelley.DPState
{ Shelley.dpsDState = dstate
- Update readme to address issues and questions presented by CPS-0001 - Update CDDL to support a more flexible scoping structure for future expansion
![iohk-bors[bot]](https://avatars.githubusercontent.com/in/17473?v=4&s=80)
4470: db-analyser: make tracer atomic r=amesgen a=amesgen # Description When enabling verbose logging, tracers from ChainDB background threads can cause undesirable interleavings. Co-authored-by: Alexander Esgen <[email protected]>
When enabling verbose logging, tracers from ChainDB background threads can cause undesirable interleavings.