Merge pull request #1999 from IntersectMBO/utxo-hd

Utxo hd

Author: kderme

cabal.project

@@ -75,7 +75,7 @@ constraints:
   -- then clashes with the `show` in `Prelude`.
   , text < 2.1.2
 
-  , cardano-node ^>= 10.3
+  , cardano-node ^>= 10.4
 
 if impl (ghc >= 9.12)
   allow-newer:

cardano-chain-gen/src/Cardano/Mock/Chain.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -17,6 +18,7 @@ module Cardano.Mock.Chain (
 ) where
 
 import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Ledger.Basics (EmptyMK, ValuesMK)
 import qualified Ouroboros.Consensus.Ledger.Extended as Consensus
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import Ouroboros.Network.Block
@@ -28,7 +30,7 @@ data Chain' block st
   | Chain' block st :> (block, st)
   deriving (Eq, Ord, Show, Functor)
 
-type State block = Consensus.ExtLedgerState block
+type State block = (Consensus.ExtLedgerState block EmptyMK, Consensus.LedgerTables (Consensus.ExtLedgerState block) ValuesMK)
 
 type Chain block = Chain' block (State block)
 

cardano-chain-gen/src/Cardano/Mock/ChainDB.hs

@@ -2,13 +2,15 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MonoLocalBinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Cardano.Mock.ChainDB (
   ChainDB (..),
+  currentState,
   initChainDB,
   headTip,
-  currentState,
   replaceGenesisDB,
   extendChainDB,
   findFirstPoint,
@@ -19,10 +21,15 @@ module Cardano.Mock.ChainDB (
 
 import Cardano.Mock.Chain
 import Ouroboros.Consensus.Block
+import Ouroboros.Consensus.Cardano.CanHardFork ()
+import Ouroboros.Consensus.Cardano.Ledger ()
 import Ouroboros.Consensus.Config
 import Ouroboros.Consensus.Ledger.Abstract
 import qualified Ouroboros.Consensus.Ledger.Extended as Consensus
-import Ouroboros.Consensus.Ledger.SupportsProtocol
+import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol)
+import qualified Ouroboros.Consensus.Ledger.Tables as Consensus
+import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffsMK, forgetLedgerTables, restrictValuesMK)
+import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
 import Ouroboros.Network.Block (Tip (..))
 
 -- | Thin layer around 'Chain' that knows how to apply blocks and maintain
@@ -41,7 +48,10 @@ instance Eq (Chain block) => Eq (ChainDB block) where
 instance Show (Chain block) => Show (ChainDB block) where
   show = show . cchain
 
-initChainDB :: TopLevelConfig block -> State block -> ChainDB block
+initChainDB ::
+  TopLevelConfig block ->
+  State block ->
+  ChainDB block
 initChainDB config st = ChainDB config (Genesis st)
 
 headTip :: HasHeader block => ChainDB block -> Tip block
@@ -56,14 +66,42 @@ currentState chainDB =
     Genesis st -> st
     _ :> (_, st) -> st
 
-replaceGenesisDB :: ChainDB block -> State block -> ChainDB block
+replaceGenesisDB ::
+  ChainDB block ->
+  State block ->
+  ChainDB block
 replaceGenesisDB chainDB st = chainDB {cchain = Genesis st}
 
-extendChainDB :: LedgerSupportsProtocol block => ChainDB block -> block -> ChainDB block
+extendChainDB ::
+  forall block.
+  LedgerSupportsProtocol block =>
+  ChainDB block ->
+  block ->
+  ChainDB block
 extendChainDB chainDB blk = do
   let !chain = cchain chainDB
-      !st = tickThenReapply ComputeLedgerEvents (Consensus.ExtLedgerCfg $ chainConfig chainDB) blk (getTipState chain)
-   in chainDB {cchain = chain :> (blk, st)}
+      -- Get the current ledger state
+      (tipState, tables) = getTipState chain
+      -- Apply the block and compute the diffs
+      keys :: LedgerTables (Consensus.ExtLedgerState block) KeysMK
+      keys = getBlockKeySets blk
+      ledgerTables = Consensus.getLedgerTables tables
+      restrictedTables = restrictValuesMK ledgerTables (Consensus.getLedgerTables keys)
+      ledgerState = Consensus.withLedgerTables tipState (Consensus.LedgerTables restrictedTables)
+      !diffState =
+        tickThenReapply
+          ComputeLedgerEvents
+          (Consensus.ExtLedgerCfg $ chainConfig chainDB)
+          blk
+          ledgerState
+      !ledgerTables' =
+        Consensus.LedgerTables
+          . applyDiffsMK ledgerTables
+          . Consensus.getLedgerTables
+          . Consensus.projectLedgerTables
+          $ diffState
+      !ledgerState' = forgetLedgerTables diffState
+   in chainDB {cchain = chain :> (blk, (ledgerState', ledgerTables'))}
 
 findFirstPoint :: HasHeader block => [Point block] -> ChainDB block -> Maybe (Point block)
 findFirstPoint points chainDB = findFirstPointChain points (cchain chainDB)

cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs

@@ -55,7 +55,7 @@ import Network.TypedProtocol.Stateful.Codec ()
 import qualified Network.TypedProtocol.Stateful.Peer as St
 import Ouroboros.Consensus.Block (CodecConfig, HasHeader, Point, StandardHash, castPoint)
 import Ouroboros.Consensus.Config (TopLevelConfig, configCodec)
-import Ouroboros.Consensus.Ledger.Query (BlockQuery, ShowQuery)
+import Ouroboros.Consensus.Ledger.Query (BlockQuery, BlockSupportsLedgerQuery, QueryFootprint (..), ShowQuery)
 import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, TxId)
 import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol)
 import Ouroboros.Consensus.Network.NodeToClient (Apps (..), Codecs' (..), DefaultCodecs)
@@ -125,12 +125,20 @@ readChain :: MonadSTM m => ServerHandle m blk -> STM m (Chain blk)
 readChain handle = do
   cchain . chainDB <$> readTVar (chainProducerState handle)
 
-addBlock :: (LedgerSupportsProtocol blk, MonadSTM m) => ServerHandle m blk -> blk -> STM m ()
+addBlock ::
+  (LedgerSupportsProtocol blk, MonadSTM m) =>
+  ServerHandle m blk ->
+  blk ->
+  STM m ()
 addBlock handle blk =
   modifyTVar (chainProducerState handle) $
     addBlockState blk
 
-rollback :: (LedgerSupportsProtocol blk, MonadSTM m) => ServerHandle m blk -> Point blk -> STM m ()
+rollback ::
+  (LedgerSupportsProtocol blk, MonadSTM m) =>
+  ServerHandle m blk ->
+  Point blk ->
+  STM m ()
 rollback handle point =
   modifyTVar (chainProducerState handle) $ \st ->
     case rollbackState point st of
@@ -153,7 +161,8 @@ stopServer sh = do
 
 type MockServerConstraint blk =
   ( SerialiseNodeToClientConstraints blk
-  , ShowQuery (BlockQuery blk)
+  , BlockSupportsLedgerQuery blk
+  , ShowQuery (BlockQuery blk 'QFNoTables)
   , StandardHash blk
   , ShowProxy (ApplyTxErr blk)
   , Serialise (HeaderHash blk)
@@ -167,7 +176,6 @@ type MockServerConstraint blk =
   )
 
 forkServerThread ::
-  forall blk.
   MockServerConstraint blk =>
   IOManager ->
   TopLevelConfig blk ->
@@ -183,7 +191,6 @@ forkServerThread iom config initSt netMagic path = do
   pure $ ServerHandle chainSt threadVar runThread
 
 withServerHandle ::
-  forall blk a.
   MockServerConstraint blk =>
   IOManager ->
   TopLevelConfig blk ->

cardano-chain-gen/src/Cardano/Mock/ChainSync/State.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -52,7 +53,10 @@ data FollowerNext
   | FollowerForwardFrom
   deriving (Eq, Show)
 
-initChainProducerState :: TopLevelConfig block -> Chain.State block -> ChainProducerState block
+initChainProducerState ::
+  TopLevelConfig block ->
+  Chain.State block ->
+  ChainProducerState block
 initChainProducerState config st = ChainProducerState (initChainDB config st) Map.empty 0
 
 -- | Add a block to the chain. It does not require any follower's state changes.