From b42eeda13cc6ce0464e54ae631446472ebc38fca Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 25 Mar 2024 13:35:01 +0100 Subject: [PATCH] Fix LedgerState --- cabal.project | 36 +---- .../internal/Cardano/Api/LedgerState.hs | 141 +++++++++++------- 2 files changed, 97 insertions(+), 80 deletions(-) diff --git a/cabal.project b/cabal.project index 3e9dc647f1..9df057fcb6 100644 --- a/cabal.project +++ b/cabal.project @@ -13,8 +13,8 @@ repository cardano-haskell-packages -- See CONTRIBUTING for information about these, including some Nix commands -- you need to run if you change them index-state: - , hackage.haskell.org 2024-03-18T10:10:55Z - , cardano-haskell-packages 2024-03-15T18:07:40Z + , hackage.haskell.org 2024-03-25T10:39:21Z + , cardano-haskell-packages 2024-03-22T16:27:41Z packages: cardano-api @@ -42,42 +42,20 @@ write-ghc-environment-files: always source-repository-package type: git location: https://github.com/jasagredo/latex-svg - tag: 00e10224a96ce73e2a1da8478efb7790cf9ba2b3 - --sha256: 0pb5azww7qj0armldn95pr1vxz30gq51mz8ysmm0a1rgsxm9f3i5 + tag: c52c9905cb043ddb430c93b41ce431a7506a300d + --sha256: 0h9yrlvmyi32zlr0cj2nx8ik0y2cg5ckcxq4lgq5vvjyl6lhzrbk subdir: latex-svg-image -source-repository-package - type: git - location: https://github.com/input-output-hk/quickcheck-dynamic - tag: cf5273faabde55dc8e759e64766e3353439ac1e2 - --sha256: 1achsw9pzrg9lng7xmcnkc6fz1hrl1g8bm4g33lv0vzhrkcy0cl3 - subdir: quickcheck-dynamic - -source-repository-package - type: git - location: https://github.com/well-typed/quickcheck-lockstep - tag: 5125b458af594cb191c8979a3987f1894a96a196 - --sha256: 1mv6ylpksppjdqjjm0bf0pcxlsgk2bgz60i4l4jwl1kdp0zv4iay - -source-repository-package - type: git - location: https://github.com/input-output-hk/anti-diffs - tag: a6b3b7748711c10fc0413cbe6171b42774d08ffa - --sha256: 1cqnqq2zwlrz44iq636ai81f3pfwqjaxrm9n9k7rax5yi3n139xr - subdir: - diff-containers - fingertree-rm - -if impl(ghc >= 9.8) +if impl(ghc >= 9.6) allow-newer: cardano-lmdb-simple:bytestring source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-consensus - tag: 31fbe404a676d9a60c3327a29d6d32ce4d50b98f - --sha256: 04n2sawv17dw95f8xyiv74navcidyzwkpc05kyiak95ias3k20ax + tag: 0bd40d306bd7c44a13d192f9e7a2f58c27c9b045 + --sha256: 18dam0adi3n1mkcqjvbvc40d7qj72npsyq9lr3yp3z7x9c9lhg96 subdir: ouroboros-consensus ouroboros-consensus-cardano diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index 2e1ca33b9e..2e4abbe2c6 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -157,6 +157,8 @@ import qualified Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common as import Ouroboros.Consensus.HardFork.Combinator.State.Types import qualified Ouroboros.Consensus.Ledger.Abstract as Ledger import Ouroboros.Consensus.Ledger.Basics (LedgerResult (lrEvents), lrResult) +import Ouroboros.Consensus.Ledger.Tables.Utils +import Ouroboros.Consensus.Ledger.Tables (LedgerTables(..)) import qualified Ouroboros.Consensus.Ledger.Basics as Ledger import qualified Ouroboros.Consensus.Ledger.Extended as Ledger import qualified Ouroboros.Consensus.Mempool.Capacity as TxLimits @@ -335,37 +337,37 @@ applyBlock env oldState validationMode block pattern LedgerStateByron :: Ledger.LedgerState Byron.ByronBlock mk -> LedgerState -pattern LedgerStateByron st <- LedgerState (Consensus.LedgerStateByron st) +pattern LedgerStateByron st <- LedgerState (Consensus.LedgerStateByron st) tbs pattern LedgerStateShelley :: Ledger.LedgerState (Shelley.ShelleyBlock protocol (Shelley.ShelleyEra Consensus.StandardCrypto)) mk -> LedgerState -pattern LedgerStateShelley st <- LedgerState (Consensus.LedgerStateShelley st) +pattern LedgerStateShelley st <- LedgerState (Consensus.LedgerStateShelley st) tbs pattern LedgerStateAllegra :: Ledger.LedgerState (Shelley.ShelleyBlock protocol (Shelley.AllegraEra Consensus.StandardCrypto)) mk -> LedgerState -pattern LedgerStateAllegra st <- LedgerState (Consensus.LedgerStateAllegra st) +pattern LedgerStateAllegra st <- LedgerState (Consensus.LedgerStateAllegra st) tbs pattern LedgerStateMary :: Ledger.LedgerState (Shelley.ShelleyBlock protocol (Shelley.MaryEra Consensus.StandardCrypto)) mk -> LedgerState -pattern LedgerStateMary st <- LedgerState (Consensus.LedgerStateMary st) +pattern LedgerStateMary st <- LedgerState (Consensus.LedgerStateMary st) tbs pattern LedgerStateAlonzo :: Ledger.LedgerState (Shelley.ShelleyBlock protocol (Shelley.AlonzoEra Consensus.StandardCrypto)) mk -> LedgerState -pattern LedgerStateAlonzo st <- LedgerState (Consensus.LedgerStateAlonzo st) +pattern LedgerStateAlonzo st <- LedgerState (Consensus.LedgerStateAlonzo st) tbs pattern LedgerStateBabbage :: Ledger.LedgerState (Shelley.ShelleyBlock protocol (Shelley.BabbageEra Consensus.StandardCrypto)) mk -> LedgerState -pattern LedgerStateBabbage st <- LedgerState (Consensus.LedgerStateBabbage st) +pattern LedgerStateBabbage st <- LedgerState (Consensus.LedgerStateBabbage st) tbs pattern LedgerStateConway :: Ledger.LedgerState (Shelley.ShelleyBlock protocol (Shelley.ConwayEra Consensus.StandardCrypto)) mk -> LedgerState -pattern LedgerStateConway st <- LedgerState (Consensus.LedgerStateConway st) +pattern LedgerStateConway st <- LedgerState (Consensus.LedgerStateConway st) tbs {-# COMPLETE LedgerStateByron , LedgerStateShelley @@ -1034,11 +1036,12 @@ readByteString fp cfgType = (liftEither <=< liftIO) $ initLedgerStateVar :: GenesisConfig -> LedgerState initLedgerStateVar genesisConfig = LedgerState { clsState = - HFC.HardForkLedgerState - $ hcmap - (Proxy @(Compose Ledger.CanStowLedgerTables Ledger.LedgerState)) - (Flip . Ledger.stowLedgerTables . unFlip) - $ HFC.hardForkLedgerStatePerEra + Ledger.ledgerState + $ forgetLedgerTables + $ Consensus.pInfoInitLedger + $ fst protocolInfo + , clsTables = + Ledger.projectLedgerTables $ Ledger.ledgerState $ Consensus.pInfoInitLedger $ fst protocolInfo @@ -1060,7 +1063,7 @@ getAnyNewEpochState :: ShelleyBasedEra era -> LedgerState -> Either LedgerStateError AnyNewEpochState -getAnyNewEpochState sbe (LedgerState ls) = +getAnyNewEpochState sbe (LedgerState ls tbs) = AnyNewEpochState sbe <$> getNewEpochState sbe ls getNewEpochState @@ -1143,10 +1146,13 @@ pattern ConwayLedgerState pattern ConwayLedgerState x = S (S (S (S (S (S (Z x)))))) encodeLedgerState :: LedgerState -> CBOR.Encoding -encodeLedgerState (LedgerState (HFC.HardForkLedgerState st)) = - HFC.encodeTelescope +encodeLedgerState (LedgerState (HFC.HardForkLedgerState st) tbs) = mconcat + [ CBOR.encodeListLen 2 + , HFC.encodeTelescope (byron :* shelley :* allegra :* mary :* alonzo :* babbage :* conway :* Nil) st + , Ledger.valuesMKEncoder tbs + ] where byron = fn (K . Byron.encodeByronLedgerState . unFlip) shelley = fn (K . Shelley.encodeShelleyLedgerState . unFlip) @@ -1157,9 +1163,11 @@ encodeLedgerState (LedgerState (HFC.HardForkLedgerState st)) = conway = fn (K . Shelley.encodeShelleyLedgerState . unFlip) decodeLedgerState :: forall s. CBOR.Decoder s LedgerState -decodeLedgerState = +decodeLedgerState = do + 2 <- CBOR.decodeListLen LedgerState . HFC.HardForkLedgerState <$> HFC.decodeTelescope (byron :* shelley :* allegra :* mary :* alonzo :* babbage :* conway :* Nil) + <*> Ledger.valuesMKDecoder where byron = Comp $ Flip <$> Byron.decodeByronLedgerState shelley = Comp $ Flip <$> Shelley.decodeShelleyLedgerState @@ -1176,14 +1184,12 @@ toLedgerStateEvents :: ( Ledger.LedgerState (HFC.HardForkBlock (Consensus.CardanoEras Consensus.StandardCrypto)) ) - ( Ledger.LedgerState - (HFC.HardForkBlock (Consensus.CardanoEras Consensus.StandardCrypto)) - Ledger.EmptyMK + ( LedgerState ) -> LedgerStateEvents toLedgerStateEvents lr = (ledgerState, ledgerEvents) where - ledgerState = LedgerState (lrResult lr) + ledgerState = lrResult lr ledgerEvents = mapMaybe (toLedgerEvent . WrapLedgerEvent @(HFC.HardForkBlock (Consensus.CardanoEras Consensus.StandardCrypto))) $ lrEvents lr @@ -1535,10 +1541,9 @@ applyBlock' -> Either LedgerStateError LedgerStateEvents applyBlock' env oldState validationMode block = do let config = envLedgerConfig env - stateOld = clsState oldState case validationMode of - FullValidation -> tickThenApply config block stateOld - QuickValidation -> tickThenReapplyCheckHash config block stateOld + FullValidation -> tickThenApply config block oldState + QuickValidation -> tickThenReapplyCheckHash config block oldState applyBlockWithEvents :: Env @@ -1550,10 +1555,9 @@ applyBlockWithEvents -> Either LedgerStateError LedgerStateEvents applyBlockWithEvents env oldState enableValidation block = do let config = envLedgerConfig env - stateOld = clsState oldState if enableValidation - then tickThenApply config block stateOld - else tickThenReapplyCheckHash config block stateOld + then tickThenApply config block oldState + else tickThenReapplyCheckHash config block oldState -- Like 'Consensus.tickThenReapply' but also checks that the previous hash from -- the block matches the head hash of the ledger state. @@ -1561,30 +1565,47 @@ tickThenReapplyCheckHash :: HFC.HardForkLedgerConfig (Consensus.CardanoEras Consensus.StandardCrypto) -> Consensus.CardanoBlock Consensus.StandardCrypto - -> Ledger.LedgerState - (HFC.HardForkBlock - (Consensus.CardanoEras Consensus.StandardCrypto)) - Ledger.EmptyMK + -> LedgerState -> Either LedgerStateError LedgerStateEvents -tickThenReapplyCheckHash cfg block lsb = - if Consensus.blockPrevHash block == Ledger.ledgerTipHash lsb - then Right - . toLedgerStateEvents - $ Ledger.tickThenReapplyLedgerResult - cfg - block - lsb +tickThenReapplyCheckHash cfg block (LedgerState st tbs) = + if Consensus.blockPrevHash block == Ledger.ledgerTipHash st + then + let + keys :: LedgerTables (Ledger.LedgerState (Consensus.CardanoBlock Consensus.StandardCrypto)) Ledger.KeysMK + keys = Ledger.getBlockKeySets block + + restrictedTables = + LedgerTables (rawRestrictValues (getLedgerTables tbs) (getLedgerTables keys)) + + + ledgerResult = + Ledger.tickThenReapplyLedgerResult cfg block + $ st `Ledger.withLedgerTables` restrictedTables + + in Right + . toLedgerStateEvents + . fmap (\stt -> LedgerState + (forgetLedgerTables stt) + ( LedgerTables + . rawApplyDiffs (getLedgerTables tbs) + . getLedgerTables + . Ledger.projectLedgerTables + $ stt + ) + ) + $ ledgerResult + else Left $ ApplyBlockHashMismatch $ mconcat [ "Ledger state hash mismatch. Ledger head is slot " , textShow $ Slot.unSlotNo $ Slot.fromWithOrigin (Slot.SlotNo 0) - (Ledger.ledgerTipSlot lsb) + (Ledger.ledgerTipSlot st) , " hash " , renderByteArray $ unChainHash - $ Ledger.ledgerTipHash lsb + $ Ledger.ledgerTipHash st , " but block previous hash is " , renderByteArray (unChainHash $ Consensus.blockPrevHash block) , " and block current hash is " @@ -1601,18 +1622,36 @@ tickThenApply :: HFC.HardForkLedgerConfig (Consensus.CardanoEras Consensus.StandardCrypto) -> Consensus.CardanoBlock Consensus.StandardCrypto - -> Ledger.LedgerState - (HFC.HardForkBlock - (Consensus.CardanoEras Consensus.StandardCrypto)) - Ledger.EmptyMK + -> LedgerState -> Either LedgerStateError LedgerStateEvents -tickThenApply cfg block lsb - = either (Left . ApplyBlockError) (Right . toLedgerStateEvents) - $ runExcept - $ Ledger.tickThenApplyLedgerResult - cfg - block - lsb +tickThenApply cfg block (LedgerState st tbs) + = let + keys :: LedgerTables (Ledger.LedgerState (Consensus.CardanoBlock Consensus.StandardCrypto)) Ledger.KeysMK + keys = Ledger.getBlockKeySets block + + restrictedTables = + LedgerTables (rawRestrictValues (getLedgerTables tbs) (getLedgerTables keys)) + + eLedgerResult = runExcept + $ Ledger.tickThenApplyLedgerResult cfg block + $ st `Ledger.withLedgerTables` restrictedTables + in + either + (Left . ApplyBlockError) + ( Right + . toLedgerStateEvents + . fmap (\stt -> + LedgerState + (forgetLedgerTables stt) + ( LedgerTables + . rawApplyDiffs (getLedgerTables tbs) + . getLedgerTables + . Ledger.projectLedgerTables + $ stt + ) + ) + ) + eLedgerResult renderByteArray :: ByteArrayAccess bin => bin -> Text renderByteArray =