Fix LedgerState

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

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,41 +1555,57 @@ 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.
 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 =