feature: Implement UTxO-HD

Author: sgillespie

cabal.project

@@ -78,7 +78,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 (ValuesMK)
 import qualified Ouroboros.Consensus.Ledger.Extended as Consensus
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import Ouroboros.Network.Block
@@ -30,7 +32,7 @@ data Chain' block st
 
 type State block = Consensus.ExtLedgerState block
 
-type Chain block = Chain' block (State block)
+type Chain block = Chain' block (State block ValuesMK)
 
 infixl 5 :>
 

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,14 @@ 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 Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffs)
+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 +47,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 ValuesMK ->
+  ChainDB block
 initChainDB config st = ChainDB config (Genesis st)
 
 headTip :: HasHeader block => ChainDB block -> Tip block
@@ -50,20 +59,37 @@ headTip chainDB =
     Genesis _ -> TipGenesis
     (_ :> (b, _)) -> Tip (blockSlot b) (blockHash b) (blockNo b)
 
-currentState :: ChainDB block -> State block
+currentState :: ChainDB block -> State block ValuesMK
 currentState chainDB =
   case cchain chainDB of
     Genesis st -> st
     _ :> (_, st) -> st
 
-replaceGenesisDB :: ChainDB block -> State block -> ChainDB block
+replaceGenesisDB ::
+  ChainDB block ->
+  State block ValuesMK ->
+  ChainDB block
 replaceGenesisDB chainDB st = chainDB {cchain = Genesis st}
 
-extendChainDB :: LedgerSupportsProtocol block => ChainDB block -> block -> ChainDB block
+extendChainDB ::
+  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 = getTipState chain
+      -- Apply the block and compute the diffs
+      !diffState =
+        tickThenReapply
+          ComputeLedgerEvents
+          (Consensus.ExtLedgerCfg $ chainConfig chainDB)
+          blk
+          tipState
+      -- Apply the diffs
+      !newTipState = applyDiffs tipState diffState
+   in chainDB {cchain = chain :> (blk, newTipState)}
 
 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,8 @@ 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.Basics (ValuesMK)
+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)
@@ -116,7 +117,7 @@ data ServerHandle m blk = ServerHandle
   , forkAgain :: m (Async ())
   }
 
-replaceGenesis :: MonadSTM m => ServerHandle m blk -> State blk -> STM m ()
+replaceGenesis :: MonadSTM m => ServerHandle m blk -> State blk ValuesMK -> STM m ()
 replaceGenesis handle st =
   modifyTVar (chainProducerState handle) $ \cps ->
     cps {chainDB = replaceGenesisDB (chainDB cps) st}
@@ -125,12 +126,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 +162,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,11 +177,10 @@ type MockServerConstraint blk =
   )
 
 forkServerThread ::
-  forall blk.
   MockServerConstraint blk =>
   IOManager ->
   TopLevelConfig blk ->
-  State blk ->
+  State blk ValuesMK ->
   NetworkMagic ->
   FilePath ->
   IO (ServerHandle IO blk)
@@ -183,11 +192,10 @@ forkServerThread iom config initSt netMagic path = do
   pure $ ServerHandle chainSt threadVar runThread
 
 withServerHandle ::
-  forall blk a.
   MockServerConstraint blk =>
   IOManager ->
   TopLevelConfig blk ->
-  State blk ->
+  State blk ValuesMK ->
   NetworkMagic ->
   FilePath ->
   (ServerHandle IO blk -> IO a) ->

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -23,6 +24,7 @@ import qualified Data.Map.Strict as Map
 import Ouroboros.Consensus.Block (HasHeader, HeaderHash, Point, blockPoint, castPoint)
 import Ouroboros.Consensus.Config (TopLevelConfig)
 import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol)
+import Ouroboros.Consensus.Ledger.Tables (ValuesMK)
 import Ouroboros.Network.Block (ChainUpdate (..))
 
 data ChainProducerState block = ChainProducerState
@@ -52,7 +54,10 @@ data FollowerNext
   | FollowerForwardFrom
   deriving (Eq, Show)
 
-initChainProducerState :: TopLevelConfig block -> Chain.State block -> ChainProducerState block
+initChainProducerState ::
+  TopLevelConfig block ->
+  Chain.State block ValuesMK ->
+  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.

cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs

@@ -81,20 +81,22 @@ import Ouroboros.Consensus.Cardano.Block (
   ShelleyEra,
  )
 import Ouroboros.Consensus.Cardano.CanHardFork ()
+import Ouroboros.Consensus.Cardano.Ledger ()
 import Ouroboros.Consensus.Config (
   TopLevelConfig,
   configConsensus,
   configLedger,
   topLevelConfigLedger,
  )
+import Ouroboros.Consensus.Shelley.Ledger.Ledger
 
 import Ouroboros.Consensus.Forecast (Forecast (..))
 import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as Consensus
 import Ouroboros.Consensus.HardFork.Combinator.Ledger ()
 import qualified Ouroboros.Consensus.HardFork.Combinator.Mempool as Consensus
 import Ouroboros.Consensus.HeaderValidation (headerStateChainDep)
 import Ouroboros.Consensus.Ledger.Abstract (TickedLedgerState, applyChainTick)
-import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..))
+import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..), ValuesMK)
 import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, headerState, ledgerState)
 import Ouroboros.Consensus.Ledger.SupportsMempool (
   ApplyTxErr,
@@ -104,6 +106,7 @@ import Ouroboros.Consensus.Ledger.SupportsMempool (
   applyTx,
  )
 import Ouroboros.Consensus.Ledger.SupportsProtocol (ledgerViewForecastAt)
+import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables)
 import Ouroboros.Consensus.Node.ProtocolInfo (
   ProtocolInfo,
   pInfoConfig,
@@ -118,7 +121,7 @@ import Ouroboros.Consensus.Protocol.Abstract (
 import Ouroboros.Consensus.Protocol.Praos ()
 import Ouroboros.Consensus.Protocol.TPraos ()
 import Ouroboros.Consensus.Shelley.HFEras ()
-import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock, Ticked, shelleyLedgerState)
+import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
 import qualified Ouroboros.Consensus.Shelley.Ledger.Mempool as Consensus
 import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
 import qualified Ouroboros.Consensus.TypeFamilyWrappers as Consensus
@@ -232,13 +235,13 @@ initInterpreter ::
 initInterpreter pinfo forging traceForge mFingerprintFile = do
   let topLeverCfg = pInfoConfig pinfo
   let initSt = pInfoInitLedger pinfo
-  let ledgerView = mkForecast topLeverCfg initSt
+  let ledgerView' = mkForecast topLeverCfg initSt
   (mode, fingerprint) <- mkFingerprint mFingerprintFile
   stvar <-
     newTVarIO $
       InterpreterState
         { istChain = initChainDB topLeverCfg initSt
-        , istForecast = ledgerView
+        , istForecast = ledgerView'
         , istSlot = SlotNo 0
         , -- The first real Byron block (ie block that can contain txs) is number 1.
           istNextBlockNo = BlockNo 1
@@ -360,20 +363,22 @@ forgeNextLeaders interpreter txes possibleLeaders = do
             else throwIO $ FailedToValidateSlot currentSlot (lengthSlots <$> istFingerprint interState) (interpFingerFile interpreter)
         Just (proof, blockForging) -> do
           -- Tick the ledger state for the 'SlotNo' we're producing a block for
-          let tickedLedgerSt :: Ticked (LedgerState CardanoBlock)
-              !tickedLedgerSt =
+          let ledgerState' = ledgerState $ currentState (istChain interState)
+
+              tickedLedgerSt =
                 applyChainTick
                   ComputeLedgerEvents
                   (configLedger cfg)
                   currentSlot
-                  (ledgerState . currentState $ istChain interState)
+                  (forgetLedgerTables ledgerState')
+
           !blk <-
             Block.forgeBlock
               blockForging
               cfg
               (istNextBlockNo interState)
               currentSlot
-              tickedLedgerSt
+              (forgetLedgerTables tickedLedgerSt)
               (mkValidated <$> txes)
               proof
 
@@ -384,7 +389,7 @@ forgeNextLeaders interpreter txes possibleLeaders = do
     _applyTxs ::
       [Consensus.GenTx CardanoBlock] ->
       SlotNo ->
-      TickedLedgerState CardanoBlock ->
+      TickedLedgerState CardanoBlock ValuesMK ->
       Either (ApplyTxErr CardanoBlock) [Validated (GenTx CardanoBlock)]
     _applyTxs genTxs slotNo st =
       runExcept
@@ -405,7 +410,7 @@ tryAllForging interpreter interState currentSlot xs = do
       let cfg = interpTopLeverConfig interpreter
 
       -- We require the ticked ledger view in order to construct the ticked 'ChainDepState'.
-      ledgerView <- case runExcept (forecastFor (istForecast interState) currentSlot) of
+      ledgerView' <- case runExcept (forecastFor (istForecast interState) currentSlot) of
         Right lv -> pure (lv :: (LedgerView (BlockProtocol CardanoBlock)))
         -- Left can only happen if we cross an epoch boundary
         Left err -> throwIO $ ForecastError currentSlot err
@@ -417,7 +422,7 @@ tryAllForging interpreter interState currentSlot xs = do
           !tickedChainDepState =
             tickChainDepState
               (configConsensus cfg)
-              ledgerView
+              ledgerView'
               currentSlot
               (headerStateChainDep (headerState $ currentState $ istChain interState))
 
@@ -471,7 +476,7 @@ rollbackInterpreter interpreter pnt = do
 getCurrentInterpreterState :: Interpreter -> IO InterpreterState
 getCurrentInterpreterState = readTVarIO . interpState
 
-getCurrentLedgerState :: Interpreter -> IO (ExtLedgerState CardanoBlock)
+getCurrentLedgerState :: Interpreter -> IO (ExtLedgerState CardanoBlock ValuesMK)
 getCurrentLedgerState = fmap (currentState . istChain) . getCurrentInterpreterState
 
 getNextBlockNo :: Interpreter -> IO BlockNo
@@ -495,7 +500,7 @@ getCurrentSlot interp = istSlot <$> readTVarIO (interpState interp)
 
 withBabbageLedgerState ::
   Interpreter ->
-  (LedgerState (ShelleyBlock PraosStandard BabbageEra) -> Either ForgingError a) ->
+  (LedgerState (ShelleyBlock PraosStandard BabbageEra) ValuesMK -> Either ForgingError a) ->
   IO a
 withBabbageLedgerState inter mk = do
   st <- getCurrentLedgerState inter
@@ -507,7 +512,7 @@ withBabbageLedgerState inter mk = do
 
 withConwayLedgerState ::
   Interpreter ->
-  (LedgerState (ShelleyBlock PraosStandard ConwayEra) -> Either ForgingError a) ->
+  (LedgerState (ShelleyBlock PraosStandard ConwayEra) ValuesMK -> Either ForgingError a) ->
   IO a
 withConwayLedgerState inter mk = do
   st <- getCurrentLedgerState inter
@@ -519,7 +524,7 @@ withConwayLedgerState inter mk = do
 
 withAlonzoLedgerState ::
   Interpreter ->
-  (LedgerState (ShelleyBlock TPraosStandard AlonzoEra) -> Either ForgingError a) ->
+  (LedgerState (ShelleyBlock TPraosStandard AlonzoEra) ValuesMK -> Either ForgingError a) ->
   IO a
 withAlonzoLedgerState inter mk = do
   st <- getCurrentLedgerState inter
@@ -531,7 +536,7 @@ withAlonzoLedgerState inter mk = do
 
 withShelleyLedgerState ::
   Interpreter ->
-  (LedgerState (ShelleyBlock TPraosStandard ShelleyEra) -> Either ForgingError a) ->
+  (LedgerState (ShelleyBlock TPraosStandard ShelleyEra) ValuesMK -> Either ForgingError a) ->
   IO a
 withShelleyLedgerState inter mk = do
   st <- getCurrentLedgerState inter
@@ -623,9 +628,12 @@ mkValidated txe =
 
 mkForecast ::
   TopLevelConfig CardanoBlock ->
-  ExtLedgerState CardanoBlock ->
+  ExtLedgerState CardanoBlock ValuesMK ->
   Forecast (LedgerView (BlockProtocol CardanoBlock))
-mkForecast cfg st = ledgerViewForecastAt (configLedger cfg) (ledgerState st)
+mkForecast cfg st = ledgerViewForecastAt (configLedger cfg) (ledgerState st')
+  where
+    st' :: ExtLedgerState CardanoBlock ValuesMK
+    st' = st
 
 throwLeftIO :: Exception e => Either e a -> IO a
 throwLeftIO = either throwIO pure