Add neededTxInsForBlock function for UTxO on-disk

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BlockChain.hs

@@ -27,6 +27,7 @@ module Shelley.Spec.Ledger.BlockChain
     bbHash,
     bBodySize,
     slotToNonce,
+    neededTxInsForBlock,
     -- accessor functions
     bheader,
     bbody,
@@ -100,19 +101,23 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy as BSL
 import Data.Coerce (coerce)
+import Data.Foldable (toList)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Sequence (Seq)
 import qualified Data.Sequence as Seq
 import Data.Sequence.Strict (StrictSeq)
 import qualified Data.Sequence.Strict as StrictSeq
+import Data.Set (Set)
+import qualified Data.Set as Set
 import Data.Typeable
 import GHC.Generics (Generic)
 import GHC.Records (HasField (..))
 import NoThunks.Class (AllowThunksIn (..), NoThunks (..))
 import Numeric.Natural (Natural)
 import Shelley.Spec.Ledger.EpochBoundary (BlocksMade (..))
-import Shelley.Spec.Ledger.Tx (Tx, segwitTx)
+import Shelley.Spec.Ledger.Tx (Tx, TxIn (..), segwitTx)
+import Shelley.Spec.Ledger.UTxO (txid)
 
 data TxSeq era = TxSeq'
   { txSeqTxns' :: !(StrictSeq (Tx era)),
@@ -428,6 +433,28 @@ incrBlocks isOverlay hk b'@(BlocksMade b)
   where
     hkVal = Map.lookup hk b
 
+-- | The validity of any individual block depends only on a subset
+-- of the UTxO stored in the ledger state. This function returns
+-- the transaction inputs corresponding to the required UTxO for a
+-- given Block.
+--
+-- This function will be used by the consensus layer to enable storing
+-- the UTxO on disk. In particular, given a block, the consensus layer
+-- will use 'neededTxInsForBlock' to retrived the needed UTxO from disk
+-- and present only those to the ledger.
+neededTxInsForBlock ::
+  ( Era era,
+    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era)))
+  ) =>
+  Block era ->
+  Set (TxIn (Crypto era))
+neededTxInsForBlock (Block' _ txsSeq _) = Set.filter isNotNewInput allTxIns
+  where
+    txBodies = map (getField @"body") $ toList $ Era.fromTxSeq txsSeq
+    allTxIns = Set.unions $ map (getField @"inputs") txBodies
+    newTxIds = Set.fromList $ map txid txBodies
+    isNotNewInput (TxIn txID _) = txID `Set.notMember` newTxIds
+
 -- DEPRECATED
 
 {-# DEPRECATED HashHeader "Import from Cardano.Protocol.TPraos.BHeader instead" #-}

shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/TestChain.hs

@@ -77,6 +77,7 @@ import Shelley.Spec.Ledger.BlockChain
   ( Block (..),
     bbody,
     bheader,
+    neededTxInsForBlock,
   )
 import Shelley.Spec.Ledger.EpochBoundary (obligation)
 import Shelley.Spec.Ledger.LedgerState hiding (circulation)
@@ -90,8 +91,17 @@ import Shelley.Spec.Ledger.STS.Upec (votedValue)
 import Shelley.Spec.Ledger.Scripts (ScriptHash)
 import Shelley.Spec.Ledger.Tx
 import Shelley.Spec.Ledger.TxBody
-import Shelley.Spec.Ledger.UTxO (balance, totalDeposits, txins, txouts, pattern UTxO)
-import Test.QuickCheck (Property, Testable (..), conjoin, counterexample, withMaxSuccess, (.||.), (===))
+import Shelley.Spec.Ledger.UTxO (UTxO (..), balance, totalDeposits, txins, txouts, pattern UTxO)
+import Test.QuickCheck
+  ( Property,
+    Testable (..),
+    conjoin,
+    counterexample,
+    withMaxSuccess,
+    (.&&.),
+    (.||.),
+    (===),
+  )
 import Test.Shelley.Spec.Ledger.Generator.Block (tickChainState)
 import Test.Shelley.Spec.Ledger.Generator.Core (GenEnv)
 import Test.Shelley.Spec.Ledger.Generator.EraGen (EraGen (..))
@@ -200,6 +210,7 @@ adaPreservationChain =
         map (preserveBalanceRestricted @era @ledger) ssts,
         map (preserveOutputsTx @era @ledger) ssts,
         map (potsRewardsDecreaseByWdrlsPerTx @era @ledger) ssts,
+        map (canRestrictUTxO @era @ledger) ssts,
         -- well formed deposits
         map nonNegativeDeposits ssts,
         -- non-epoch-boundary preservation properties
@@ -602,6 +613,28 @@ preserveOutputsTx SourceSignalTarget {source = chainSt, signal = block} =
        in property $
             hasFailedScripts tx || outs `Map.isSubmapOf` u'
 
+canRestrictUTxO ::
+  forall era ledger.
+  ( ChainProperty era,
+    TestingLedger era ledger,
+    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era)))
+  ) =>
+  SourceSignalTarget (CHAIN era) ->
+  Property
+canRestrictUTxO SourceSignalTarget {source = chainSt, signal = block} =
+  conjoin $
+    map outputPreserved $
+      zip (sourceSignalTargets ledgerTrFull) (sourceSignalTargets ledgerTrRestr)
+  where
+    (_, ledgerTrFull) = ledgerTraceFromBlock @era @ledger chainSt block
+    (UTxO irrelevantUTxO, ledgerTrRestr) =
+      ledgerTraceFromBlockWithRestrictedUTxO @era @ledger chainSt block
+    outputPreserved
+      ( SourceSignalTarget {target = (UTxOState {_utxo = UTxO uFull}, _)},
+        SourceSignalTarget {target = (UTxOState {_utxo = UTxO uRestr}, _)}
+        ) =
+        (uRestr `Map.disjoint` irrelevantUTxO) .&&. uFull === (uRestr `Map.union` irrelevantUTxO)
+
 -- | Check that consumed inputs are eliminated from the resulting UTxO
 eliminateTxInputs ::
   forall era ledger.
@@ -909,6 +942,31 @@ ledgerTraceFromBlock chainSt block =
   where
     (tickedChainSt, ledgerEnv, ledgerSt0, txs) = ledgerTraceBase chainSt block
 
+-- | This function is nearly the same as ledgerTraceFromBlock, but
+-- it restricts the UTxO state to only those needed by the block.
+-- It also returns the unused UTxO for comparison later.
+ledgerTraceFromBlockWithRestrictedUTxO ::
+  forall era ledger.
+  ( ChainProperty era,
+    TestingLedger era ledger,
+    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era)))
+  ) =>
+  ChainState era ->
+  Block era ->
+  (UTxO era, Trace ledger)
+ledgerTraceFromBlockWithRestrictedUTxO chainSt block =
+  ( UTxO irrelevantUTxO,
+    runShelleyBase $
+      Trace.closure @ledger ledgerEnv ledgerSt0' txs
+  )
+  where
+    (_tickedChainSt, ledgerEnv, ledgerSt0, txs) = ledgerTraceBase chainSt block
+    txIns = neededTxInsForBlock block
+    (utxoSt, delegationSt) = ledgerSt0
+    utxo = unUTxO . _utxo $ utxoSt
+    (relevantUTxO, irrelevantUTxO) = Map.partitionWithKey (const . (`Set.member` txIns)) utxo
+    ledgerSt0' = (utxoSt {_utxo = UTxO relevantUTxO}, delegationSt)
+
 -- | Reconstruct a POOL trace from the transactions in a Block and ChainState
 poolTraceFromBlock ::
   forall era.