Implement block-submitting Imp functions

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/BlockBody/Internal.hs

@@ -47,6 +47,7 @@ import Cardano.Ledger.Binary (
  )
 import Cardano.Ledger.Core
 import Cardano.Ledger.Shelley.BlockBody (auxDataSeqDecoder)
+import Control.DeepSeq (NFData)
 import Control.Monad (unless)
 import Data.ByteString (ByteString)
 import Data.ByteString.Builder (Builder, shortByteString, toLazyByteString)
@@ -88,6 +89,8 @@ data AlonzoBlockBody era = AlonzoBlockBodyInternal
   }
   deriving (Generic)
 
+instance NFData (Tx TopTx era) => NFData (AlonzoBlockBody era)
+
 instance EraBlockBody AlonzoEra where
   type BlockBody AlonzoEra = AlonzoBlockBody AlonzoEra
   mkBasicBlockBody = mkBasicBlockBodyAlonzo

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs

@@ -55,6 +55,7 @@ import Cardano.Ledger.Shelley.Rules (
   ShelleyUtxowPredFailure,
  )
 import Cardano.Ledger.Slot (epochInfoEpoch, epochInfoFirst)
+import Control.DeepSeq (NFData)
 import Control.Monad.Trans.Reader (asks)
 import Control.State.Transition (
   Embed (..),
@@ -80,10 +81,16 @@ data AlonzoBbodyPredFailure era
   | TooManyExUnits (Mismatch RelLTEQ ExUnits)
   deriving (Generic)
 
+instance NFData (PredicateFailure (EraRule "LEDGERS" era)) => NFData (AlonzoBbodyPredFailure era)
+
 newtype AlonzoBbodyEvent era
   = ShelleyInAlonzoEvent (ShelleyBbodyEvent era)
   deriving (Generic)
 
+deriving instance
+  Eq (Event (EraRule "LEDGERS" era)) =>
+  Eq (AlonzoBbodyEvent era)
+
 type instance EraRuleFailure "BBODY" AlonzoEra = AlonzoBbodyPredFailure AlonzoEra
 
 instance InjectRuleFailure "BBODY" AlonzoBbodyPredFailure AlonzoEra

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs

@@ -14,6 +14,7 @@ module Test.Cardano.Ledger.Alonzo.TreeDiff (
 ) where
 
 import Cardano.Ledger.Alonzo (AlonzoEra)
+import Cardano.Ledger.Alonzo.BlockBody
 import Cardano.Ledger.Alonzo.Core
 import Cardano.Ledger.Alonzo.PParams
 import Cardano.Ledger.Alonzo.Plutus.Context
@@ -122,6 +123,8 @@ instance ToExpr (AlonzoTxBodyRaw TopTx AlonzoEra) where
 
 instance ToExpr (TxBody TopTx AlonzoEra)
 
+instance ToExpr (Tx TopTx era) => ToExpr (AlonzoBlockBody era)
+
 -- Tx
 instance ToExpr IsValid
 

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs

@@ -82,6 +82,7 @@ import Cardano.Ledger.Shelley.Rules (
  )
 import qualified Cardano.Ledger.Shelley.Rules as Shelley (ShelleyBbodyPredFailure (..))
 import Cardano.Ledger.Shelley.UTxO (UTxO (..), txouts, unUTxO)
+import Control.DeepSeq (NFData)
 import Control.State.Transition (
   Embed (..),
   STS (..),
@@ -119,6 +120,10 @@ deriving instance
   (Era era, Eq (PredicateFailure (EraRule "LEDGERS" era))) =>
   Eq (ConwayBbodyPredFailure era)
 
+deriving anyclass instance
+  (Era era, NFData (PredicateFailure (EraRule "LEDGERS" era))) =>
+  NFData (ConwayBbodyPredFailure era)
+
 deriving anyclass instance
   (Era era, NoThunks (PredicateFailure (EraRule "LEDGERS" era))) =>
   NoThunks (ConwayBbodyPredFailure era)

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs

@@ -1,46 +1,35 @@
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
-module Test.Cardano.Ledger.Conway.Imp.BbodySpec (
-  spec,
-) where
+module Test.Cardano.Ledger.Conway.Imp.BbodySpec (spec) where
 
-import Cardano.Ledger.BHeaderView (BHeaderView (..))
 import Cardano.Ledger.Babbage.Core
-import Cardano.Ledger.BaseTypes (BlocksMade (..), Mismatch (..), ProtVer (..), natVersion)
-import Cardano.Ledger.Block
+import Cardano.Ledger.BaseTypes (Mismatch (..), ProtVer (..), natVersion)
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Conway.PParams (ConwayEraPParams (..))
 import Cardano.Ledger.Conway.Rules (
   ConwayBbodyPredFailure (..),
   totalRefScriptSizeInBlock,
  )
-import Cardano.Ledger.Conway.State
 import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
-import Cardano.Ledger.Shelley.LedgerState
-import Cardano.Ledger.Shelley.Rules (
-  BbodyEnv (..),
-  ShelleyBbodyState (..),
- )
 import Cardano.Ledger.Shelley.Scripts (
   pattern RequireSignature,
  )
-import Cardano.Ledger.TxIn
-import Control.Monad (forM)
+import Data.Foldable (for_)
+import Data.List (inits)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
-import qualified Data.Map as Map
 import qualified Data.Sequence.Strict as SSeq
+import qualified Data.Set as Set
+import Data.Traversable (for)
 import Data.Word (Word32)
 import Lens.Micro ((&), (.~), (^.))
-import Lens.Micro.Mtl (use)
 import Test.Cardano.Ledger.Babbage.ImpTest
 import Test.Cardano.Ledger.Conway.ImpTest (ConwayEraImp)
 import Test.Cardano.Ledger.Core.Utils (txInAt)
@@ -61,38 +50,32 @@ spec = do
     let
       maxRefScriptSizePerTx = fromIntegral @Word32 @Int $ pp ^. ppMaxRefScriptSizePerTxG
       maxRefScriptSizePerBlock = fromIntegral @Word32 @Int $ pp ^. ppMaxRefScriptSizePerBlockG
+
     txScriptCounts <-
       genNumAdditionsExceeding
         scriptSize
         maxRefScriptSizePerTx
         maxRefScriptSizePerBlock
 
-    let mkTxWithNScripts n = do
-          -- Instead of using the rootTxIn, we are creating an input for each transaction
-          -- that we subsequently need to submit,
-          -- so that we can submit them independently of each other.
-          txIn <- freshKeyAddr_ >>= \addr -> sendCoinTo addr (Coin 8_000_000)
-          refIns <- replicateM n $ produceRefScript (fromPlutusScript plutusScript)
-          pure $ mkTxWithRefInputs txIn (NE.fromList refIns)
-
-    txs <- do
-      forM txScriptCounts $ \n -> do
-        mkTxWithNScripts n
-          >>= fixupFees
-          >>= updateAddrTxWits
-
-    let expectedTotalRefScriptSize = scriptSize * sum txScriptCounts
-    predFailures <- expectLeftExpr =<< tryRunBBODY txs
-    predFailures
-      `shouldBe` NE.fromList
-        [ injectFailure
-            ( BodyRefScriptsSizeTooBig $
-                Mismatch
-                  { mismatchSupplied = expectedTotalRefScriptSize
-                  , mismatchExpected = maxRefScriptSizePerBlock
-                  }
-            )
-        ]
+    txs <- for txScriptCounts $ \n -> do
+      -- Instead of using the rootTxIn, we're creating an input for each transaction
+      -- so that transactions that will be submitted in a block
+      -- can be submitted independently from the ones that prepared the
+      -- reference inputs
+      txIn <- freshKeyAddr_ >>= \addr -> sendCoinTo addr (Coin 100_000_000)
+      refIns <- replicateM n $ produceRefScript (fromPlutusScript plutusScript)
+      pure $ mkTxWithRefInputs txIn (NE.fromList refIns)
+
+    submitFailingBlock
+      txs
+      [ injectFailure
+          ( BodyRefScriptsSizeTooBig $
+              Mismatch
+                { mismatchSupplied = scriptSize * sum txScriptCounts
+                , mismatchExpected = maxRefScriptSizePerBlock
+                }
+          )
+      ]
 
   it "BodyRefScriptsSizeTooBig with reference scripts in the same block" $
     whenMajorVersionAtLeast @11 $ do
@@ -109,37 +92,24 @@ spec = do
           maxRefScriptSizePerTx
           maxRefScriptSizePerBlock
 
-      let expectedTotalRefScriptSize = scriptSize * sum txScriptCounts
-
-      -- We are creating reference scripts and transaction that depend on them in a "simulation",
-      -- so the result will be correctly constructed that are not applied to the ledger state
-      txs :: [Tx TopTx era] <- simulateThenRestore $ do
-        concat
-          <$> forM
-            txScriptCounts
-            ( \n -> do
-                -- produce reference scripts
-                refScriptTxs <-
-                  replicateM n (produceRefScriptsTx (fromPlutusScript plutusScript :| []))
+      let
+        -- These txs will be grouped into a block
+        buildTxs = for_ txScriptCounts $ \n -> do
+          refIns <- replicateM n $ produceRefScript (fromPlutusScript plutusScript)
+          submitTx $
+            mkBasicTx mkBasicTxBody
+              & bodyTxL . referenceInputsTxBodyL .~ Set.fromList refIns
 
-                -- spend using the reference scripts
-                let txIns = (`mkTxInPartial` 0) . txIdTx <$> refScriptTxs
-                rootIn <- fst <$> getImpRootTxOut
-                spendTx <- submitTxWithRefInputs rootIn (NE.fromList txIns)
-                pure $ refScriptTxs ++ [spendTx]
+      withTxsInFailingBlock
+        buildTxs
+        [ injectFailure
+            ( BodyRefScriptsSizeTooBig $
+                Mismatch
+                  { mismatchSupplied = scriptSize * sum txScriptCounts
+                  , mismatchExpected = maxRefScriptSizePerBlock
+                  }
             )
-
-      predFailures <- expectLeftExpr =<< tryRunBBODY txs
-      predFailures
-        `shouldBe` NE.fromList
-          [ injectFailure
-              ( BodyRefScriptsSizeTooBig $
-                  Mismatch
-                    { mismatchSupplied = expectedTotalRefScriptSize
-                    , mismatchExpected = maxRefScriptSizePerBlock
-                    }
-              )
-          ]
+        ]
 
   it "totalRefScriptSizeInBlock" $ do
     script <- RequireSignature @era <$> freshKeyHash
@@ -154,7 +124,7 @@ spec = do
     -- their individual reference script sizes, and then restore the original state -
     -- meaning the transactions are not actually applied.
     -- Finally, we check that the accumulated sizes from both before and after match.
-    txsWithRefScriptSizes :: ([(Tx TopTx era, Int)], Int) <- simulateThenRestore $ do
+    txsWithSizes <- simulateThenRestore $ do
       let mkTxWithExpectedSize expectedSize txAction = do
             tx <- txAction
             totalRefScriptSizeInBlock protVer [tx] <$> getUTxO `shouldReturn` expectedSize
@@ -200,24 +170,16 @@ spec = do
 
       -- check and return the accumulated reference script size of all transactions,
       -- so we can check that the same sum for the unapplied transactions matches
-      let expectedTotalRefScriptSize = 5 * scriptSize
-      totalRefScriptSizeInBlock protVer (SSeq.fromList (fst <$> txsWithRefScriptSizes))
-        <$> getUTxO `shouldReturn` expectedTotalRefScriptSize
-      pure (txsWithRefScriptSizes, expectedTotalRefScriptSize)
+      let (txs, sizes) = unzip txsWithRefScriptSizes
+      totalRefScriptSizeInBlock protVer (SSeq.fromList txs) <$> getUTxO `shouldReturn` sum sizes
 
-    let (txWithSizes, expectedTotalSize) = txsWithRefScriptSizes
+      pure txsWithRefScriptSizes
 
     -- for each prefix of the list, the accumulated sum should match the sum of the applied transactions
-    forM_ ([1 .. length txWithSizes] :: [Int]) $ \ix -> do
-      let slice = take ix txWithSizes
-
-      totalRefScriptSizeInBlock protVer (SSeq.fromList (fst <$> slice))
-        <$> getUTxO
-          `shouldReturn` (if isPostV10 protVer then sum (snd <$> slice) else 0)
-
-    totalRefScriptSizeInBlock protVer (SSeq.fromList (fst <$> txWithSizes))
-      <$> getUTxO
-        `shouldReturn` (if isPostV10 protVer then expectedTotalSize else 0)
+    for_ (drop 1 $ inits txsWithSizes) $ \prefix -> do
+      let (txs, sizes) = unzip prefix
+          expectedSize = if isPostV10 protVer then sum sizes else 0
+      totalRefScriptSizeInBlock protVer (SSeq.fromList txs) <$> getUTxO `shouldReturn` expectedSize
 
   -- disabled in conformance because submiting phase2-invalid transactions are not supported atm
   -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/910
@@ -244,7 +206,7 @@ spec = do
           else freshKeyAddrNoPtr_
       pure $ mkBasicTxOut addr mempty & referenceScriptTxOutL .~ pure (fromNativeScript script)
 
-    (txs :: [Tx TopTx era]) <- simulateThenRestore $ do
+    txs <- simulateThenRestore $ do
       -- submit an invalid transaction which attempts to consume the failing script
       -- and specifies as collateral return the txout with reference script
       createCollateralTx <-
@@ -267,25 +229,6 @@ spec = do
       <$> getUTxO
         `shouldReturn` (if isPostV10 protVer then scriptSize else 0)
   where
-    tryRunBBODY txs = do
-      let blockBody = mkBasicBlockBody @era & txSeqBlockBodyL .~ SSeq.fromList txs
-      nes <- use impNESL
-      let ls = nes ^. nesEsL . esLStateL
-          pp = nes ^. nesEsL . curPParamsEpochStateL @era
-      kh <- freshKeyHash
-      slotNo <- use impCurSlotNoG
-      let bhView =
-            BHeaderView
-              { bhviewID = kh
-              , bhviewBSize = fromIntegral $ bBodySize (ProtVer (eraProtVerLow @era) 0) blockBody
-              , bhviewHSize = 0
-              , bhviewBHash = hashBlockBody blockBody
-              , bhviewSlot = slotNo
-              }
-      tryRunImpRule @"BBODY"
-        (BbodyEnv pp (nes ^. chainAccountStateL))
-        (BbodyState ls (BlocksMade Map.empty))
-        (Block {blockHeader = bhView, blockBody})
     isPostV10 protVer = pvMajor protVer >= natVersion @11
 
 -- Generate a list of integers such that the sum of their multiples by scale is greater than toExceed

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs

@@ -23,7 +23,6 @@ import Cardano.Ledger.Shelley.LedgerState
 import Cardano.Ledger.Shelley.Rules (Event, ShelleyTickEvent (..))
 import Cardano.Ledger.Val (zero, (<->))
 import Control.Monad (forM)
-import Control.Monad.Writer (listen)
 import Data.Default (def)
 import Data.Foldable as F (foldl', traverse_)
 import Data.List.NonEmpty (NonEmpty (..))
@@ -214,18 +213,18 @@ hardForkInitiationSpec =
     submitYesVote_ (DRepVoter dRep1) govActionId
     submitYesVote_ (StakePoolVoter stakePoolId1) govActionId
     passNEpochs 2
-      & listen
-      >>= expectHardForkEvents . snd <*> pure []
+      & impEventsFrom
+      >>= expectHardForkEvents <*> pure []
     getProtVer `shouldReturn` curProtVer
     submitYesVote_ (DRepVoter dRep2) govActionId
     passNEpochs 2
-      & listen
-      >>= expectHardForkEvents . snd <*> pure []
+      & impEventsFrom
+      >>= expectHardForkEvents <*> pure []
     getProtVer `shouldReturn` curProtVer
     submitYesVote_ (StakePoolVoter stakePoolId2) govActionId
     passNEpochs 2
-      & listen
-      >>= expectHardForkEvents . snd
+      & impEventsFrom
+      >>= expectHardForkEvents
         <*> pure
           [ SomeSTSEvent @era @"TICK" . injectEvent $ ConwayHardForkEvent nextProtVer
           ]
@@ -255,13 +254,13 @@ hardForkInitiationNoDRepsSpec =
     submitYesVoteCCs_ committeeMembers' govActionId
     submitYesVote_ (StakePoolVoter stakePoolId1) govActionId
     passNEpochs 2
-      & listen
-      >>= expectHardForkEvents . snd <*> pure []
+      & impEventsFrom
+      >>= expectHardForkEvents <*> pure []
     getProtVer `shouldReturn` curProtVer
     submitYesVote_ (StakePoolVoter stakePoolId2) govActionId
     passNEpochs 2
-      & listen
-      >>= expectHardForkEvents . snd
+      & impEventsFrom
+      >>= expectHardForkEvents
         <*> pure
           [ SomeSTSEvent @era @"TICK" . injectEvent $ ConwayHardForkEvent nextProtVer
           ]

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs

@@ -25,7 +25,6 @@ import Cardano.Ledger.Conway.State
 import Cardano.Ledger.Shelley.LedgerState
 import Cardano.Ledger.Shelley.Rules (Event, ShelleyTickEvent (..))
 import Cardano.Ledger.Val
-import Control.Monad.Writer (listen)
 import Data.Default (Default (..))
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
@@ -528,7 +527,7 @@ eventsSpec = describe "Events" $ do
           | Just (TickNewEpochEvent (EpochEvent (GovInfoEvent {})) :: ShelleyTickEvent era) <- cast ev = True
         isGovInfoEvent _ = False
         passEpochWithNoDroppedActions = do
-          (_, evs) <- listen passEpoch
+          evs <- impEventsFrom passEpoch
           filter isGovInfoEvent evs
             `shouldBeExpr` [ SomeSTSEvent @era @"TICK" . injectEvent $
                                GovInfoEvent mempty mempty mempty mempty
@@ -545,7 +544,7 @@ eventsSpec = describe "Events" $ do
           & bodyTxL . certsTxBodyL
             .~ SSeq.singleton (UnRegDepositTxCert rewardCred keyDeposit)
       passEpochWithNoDroppedActions
-      (_, evs) <- listen passEpoch
+      evs <- impEventsFrom passEpoch
       checkProposedParameterA
       let
         filteredEvs = filter isGovInfoEvent evs