Add neededTxInsForBlock function for UTxO on-disk

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

@@ -40,6 +40,7 @@ module Shelley.Spec.Ledger.BlockChain
     bBodySize,
     slotToNonce,
     hBbsize,
+    neededTxInsForBlock,
     -- accessor functions
     bheader,
     bhbody,
@@ -132,13 +133,16 @@ import qualified Data.ByteString.Builder.Extra as BS
 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.Ratio ((%))
 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 Data.Word (Word64)
 import GHC.Generics (Generic)
@@ -148,7 +152,8 @@ import Numeric.Natural (Natural)
 import Shelley.Spec.Ledger.EpochBoundary (BlocksMade (..))
 import Shelley.Spec.Ledger.OCert (OCert (..))
 import Shelley.Spec.Ledger.PParams (ProtVer (..))
-import Shelley.Spec.Ledger.Tx (Tx, segwitTx)
+import Shelley.Spec.Ledger.Tx (Tx, TxIn (..), segwitTx)
+import Shelley.Spec.Ledger.UTxO (txid)
 import Shelley.Spec.NonIntegral (CompareResult (..), taylorExpCmp)
 
 -- =======================================================
@@ -850,3 +855,25 @@ incrBlocks isOverlay hk b'@(BlocksMade b)
     Just n -> Map.insert hk (n + 1) 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

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

@@ -75,6 +75,7 @@ import Shelley.Spec.Ledger.BlockChain
     bhbody,
     bheader,
     bheaderSlotNo,
+    neededTxInsForBlock,
   )
 import Shelley.Spec.Ledger.EpochBoundary (obligation)
 import Shelley.Spec.Ledger.LedgerState hiding (circulation)
@@ -88,8 +89,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 (..))
@@ -198,6 +208,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
@@ -600,6 +611,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.
@@ -907,6 +940,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.