Skip to content

Commit 5e2f7c4

Browse files
neilmayhewneilmayhew
committed
Implement block-submitting Imp functions similar to the tx ones
1 parent 052b2e8 commit 5e2f7c4

File tree

11 files changed

+138
-38
lines changed

11 files changed

+138
-38
lines changed

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,7 @@ import Cardano.Ledger.Binary (
4747
)
4848
import Cardano.Ledger.Core
4949
import Cardano.Ledger.Shelley.BlockBody (auxDataSeqDecoder)
50+
import Control.DeepSeq (NFData)
5051
import Control.Monad (unless)
5152
import Data.ByteString (ByteString)
5253
import Data.ByteString.Builder (Builder, shortByteString, toLazyByteString)
@@ -88,6 +89,8 @@ data AlonzoBlockBody era = AlonzoBlockBodyInternal
8889
}
8990
deriving (Generic)
9091

92+
instance NFData (Tx TopTx era) => NFData (AlonzoBlockBody era)
93+
9194
instance EraBlockBody AlonzoEra where
9295
type BlockBody AlonzoEra = AlonzoBlockBody AlonzoEra
9396
mkBasicBlockBody = mkBasicBlockBodyAlonzo

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ module Test.Cardano.Ledger.Alonzo.TreeDiff (
1414
) where
1515

1616
import Cardano.Ledger.Alonzo (AlonzoEra)
17+
import Cardano.Ledger.Alonzo.BlockBody
1718
import Cardano.Ledger.Alonzo.Core
1819
import Cardano.Ledger.Alonzo.PParams
1920
import Cardano.Ledger.Alonzo.Plutus.Context
@@ -122,6 +123,8 @@ instance ToExpr (AlonzoTxBodyRaw TopTx AlonzoEra) where
122123

123124
instance ToExpr (TxBody TopTx AlonzoEra)
124125

126+
instance ToExpr (Tx TopTx era) => ToExpr (AlonzoBlockBody era)
127+
125128
-- Tx
126129
instance ToExpr IsValid
127130

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

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -82,6 +82,7 @@ import Cardano.Ledger.Shelley.Rules (
8282
)
8383
import qualified Cardano.Ledger.Shelley.Rules as Shelley (ShelleyBbodyPredFailure (..))
8484
import Cardano.Ledger.Shelley.UTxO (UTxO (..), txouts, unUTxO)
85+
import Control.DeepSeq (NFData)
8586
import Control.State.Transition (
8687
Embed (..),
8788
STS (..),
@@ -119,6 +120,10 @@ deriving instance
119120
(Era era, Eq (PredicateFailure (EraRule "LEDGERS" era))) =>
120121
Eq (ConwayBbodyPredFailure era)
121122

123+
deriving anyclass instance
124+
(Era era, NFData (PredicateFailure (EraRule "LEDGERS" era))) =>
125+
NFData (ConwayBbodyPredFailure era)
126+
122127
deriving anyclass instance
123128
(Era era, NoThunks (PredicateFailure (EraRule "LEDGERS" era))) =>
124129
NoThunks (ConwayBbodyPredFailure era)

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

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,10 @@ spec ::
4242
, Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
4343
, Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
4444
, Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
45+
, ToExpr (BlockBody era)
46+
, NFData (BlockBody era)
47+
, ToExpr (PredicateFailure (EraRule "BBODY" era))
48+
, NFData (PredicateFailure (EraRule "BBODY" era))
4549
) =>
4650
Spec
4751
spec = do
@@ -54,6 +58,10 @@ conwayEraGenericSpec ::
5458
, Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
5559
, Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
5660
, Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
61+
, ToExpr (BlockBody era)
62+
, NFData (BlockBody era)
63+
, ToExpr (PredicateFailure (EraRule "BBODY" era))
64+
, NFData (PredicateFailure (EraRule "BBODY" era))
5765
) =>
5866
SpecWith (ImpInit (LedgerSpec era))
5967
conwayEraGenericSpec = do

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

Lines changed: 30 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@ import Cardano.Ledger.Shelley.Scripts (
2323
)
2424
import Cardano.Ledger.TxIn
2525
import Control.Monad (forM)
26+
import Control.State.Transition (STS (PredicateFailure))
2627
import Data.List.NonEmpty (NonEmpty (..))
2728
import qualified Data.List.NonEmpty as NE
2829
import qualified Data.Sequence.Strict as SSeq
@@ -34,7 +35,15 @@ import Test.Cardano.Ledger.Core.Utils (txInAt)
3435
import Test.Cardano.Ledger.Imp.Common
3536
import Test.Cardano.Ledger.Plutus.Examples (alwaysFailsNoDatum, purposeIsWellformedNoDatum)
3637

37-
spec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
38+
spec ::
39+
forall era.
40+
( ConwayEraImp era
41+
, ToExpr (BlockBody era)
42+
, NFData (BlockBody era)
43+
, ToExpr (PredicateFailure (EraRule "BBODY" era))
44+
, NFData (PredicateFailure (EraRule "BBODY" era))
45+
) =>
46+
SpecWith (ImpInit (LedgerSpec era))
3847
spec = do
3948
it "BodyRefScriptsSizeTooBig" $ do
4049
plutusScript <- mkPlutusScript @era $ purposeIsWellformedNoDatum SPlutusV2
@@ -68,18 +77,16 @@ spec = do
6877
>>= fixupFees
6978
>>= updateAddrTxWits
7079

71-
let expectedTotalRefScriptSize = scriptSize * sum txScriptCounts
72-
predFailures <- expectLeftExpr =<< tryRunImpBBODY txs
73-
predFailures
74-
`shouldBe` NE.fromList
75-
[ injectFailure
76-
( BodyRefScriptsSizeTooBig $
77-
Mismatch
78-
{ mismatchSupplied = expectedTotalRefScriptSize
79-
, mismatchExpected = maxRefScriptSizePerBlock
80-
}
81-
)
82-
]
80+
submitFailingBlock
81+
txs
82+
[ injectFailure
83+
( BodyRefScriptsSizeTooBig $
84+
Mismatch
85+
{ mismatchSupplied = scriptSize * sum txScriptCounts
86+
, mismatchExpected = maxRefScriptSizePerBlock
87+
}
88+
)
89+
]
8390

8491
it "BodyRefScriptsSizeTooBig with reference scripts in the same block" $
8592
whenMajorVersionAtLeast @11 $ do
@@ -96,8 +103,6 @@ spec = do
96103
maxRefScriptSizePerTx
97104
maxRefScriptSizePerBlock
98105

99-
let expectedTotalRefScriptSize = scriptSize * sum txScriptCounts
100-
101106
-- We are creating reference scripts and transaction that depend on them in a "simulation",
102107
-- so the result will be correctly constructed that are not applied to the ledger state
103108
txs :: [Tx TopTx era] <- simulateThenRestore $ do
@@ -116,17 +121,16 @@ spec = do
116121
pure $ refScriptTxs ++ [spendTx]
117122
)
118123

119-
predFailures <- expectLeftExpr =<< tryRunImpBBODY txs
120-
predFailures
121-
`shouldBe` NE.fromList
122-
[ injectFailure
123-
( BodyRefScriptsSizeTooBig $
124-
Mismatch
125-
{ mismatchSupplied = expectedTotalRefScriptSize
126-
, mismatchExpected = maxRefScriptSizePerBlock
127-
}
128-
)
129-
]
124+
submitFailingBlock
125+
txs
126+
[ injectFailure
127+
( BodyRefScriptsSizeTooBig $
128+
Mismatch
129+
{ mismatchSupplied = scriptSize * sum txScriptCounts
130+
, mismatchExpected = maxRefScriptSizePerBlock
131+
}
132+
)
133+
]
130134

131135
it "totalRefScriptSizeInBlock" $ do
132136
script <- RequireSignature @era <$> freshKeyHash

‎eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Spec.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -40,6 +40,10 @@ spec ::
4040
, Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
4141
, Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
4242
, Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
43+
, ToExpr (BlockBody era)
44+
, NFData (BlockBody era)
45+
, ToExpr (PredicateFailure (EraRule "BBODY" era))
46+
, NFData (PredicateFailure (EraRule "BBODY" era))
4347
) =>
4448
Spec
4549
spec =

‎eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Imp.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,10 @@ spec ::
2424
, Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
2525
, Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
2626
, Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
27+
, NFData (BlockBody era)
28+
, ToExpr (BlockBody era)
29+
, NFData (PredicateFailure (EraRule "BBODY" era))
30+
, ToExpr (PredicateFailure (EraRule "BBODY" era))
2731
) =>
2832
Spec
2933
spec = do

‎eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs‎

Lines changed: 66 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@
1616
{-# LANGUAGE OverloadedStrings #-}
1717
{-# LANGUAGE PatternSynonyms #-}
1818
{-# LANGUAGE ScopedTypeVariables #-}
19+
{-# LANGUAGE TupleSections #-}
1920
{-# LANGUAGE TypeApplications #-}
2021
{-# LANGUAGE TypeFamilyDependencies #-}
2122
{-# LANGUAGE TypeOperators #-}
@@ -49,12 +50,17 @@ module Test.Cardano.Ledger.Shelley.ImpTest (
4950
getByronKeyPair,
5051
freshSafeHash,
5152
freshKeyHashVRF,
53+
submitBlock,
54+
submitBlock_,
5255
submitTx,
5356
submitTx_,
5457
submitTxAnn,
5558
submitTxAnn_,
59+
submitFailingBlock,
60+
submitFailingBlockM,
5661
submitFailingTx,
5762
submitFailingTxM,
63+
trySubmitBlock,
5864
trySubmitTx,
5965
impShelleyExpectTxSuccess,
6066
modifyNES,
@@ -66,7 +72,6 @@ module Test.Cardano.Ledger.Shelley.ImpTest (
6672
impAnnDoc,
6773
impLogToExpr,
6874
runImpRule,
69-
tryRunImpBBODY,
7075
tryRunImpRule,
7176
tryRunImpRuleNoAssertions,
7277
delegateStake,
@@ -235,7 +240,7 @@ import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
235240
import Cardano.Ledger.Val (Val (..))
236241
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
237242
import Cardano.Slotting.Time (mkSlotLength)
238-
import Control.Monad (forM)
243+
import Control.Monad (forM, (<=<))
239244
import Control.Monad.IO.Class
240245
import Control.Monad.Reader (MonadReader (..), asks)
241246
import Control.Monad.State.Strict (MonadState (..), evalStateT, get, gets, modify, put)
@@ -249,7 +254,7 @@ import Control.State.Transition.Extended (
249254
SingEP (..),
250255
ValidationPolicy (..),
251256
)
252-
import Data.Bifunctor (first)
257+
import Data.Bifunctor (bimap, first)
253258
import Data.Coerce (coerce)
254259
import Data.Data (Proxy (..), type (:~:) (..))
255260
import Data.Default (Default (..))
@@ -1248,35 +1253,84 @@ submitFailingTxM tx mkExpectedFailures = do
12481253
expectedFailures <- mkExpectedFailures fixedUpTx
12491254
predFailures `shouldBeExpr` expectedFailures
12501255

1251-
tryRunImpBBODY ::
1256+
submitBlock_ ::
1257+
( HasCallStack
1258+
, ShelleyEraImp era
1259+
, ToExpr (PredicateFailure (EraRule "BBODY" era))
1260+
, NFData (Block BHeaderView era)
1261+
) =>
1262+
[Tx TopTx era] -> ImpTestM era ()
1263+
submitBlock_ = void . submitBlock
1264+
1265+
submitBlock ::
1266+
( HasCallStack
1267+
, ShelleyEraImp era
1268+
, ToExpr (PredicateFailure (EraRule "BBODY" era))
1269+
, NFData (Block BHeaderView era)
1270+
) =>
1271+
[Tx TopTx era] -> ImpTestM era (Block BHeaderView era)
1272+
submitBlock = expectRightDeepExpr . first fst <=< trySubmitBlock
1273+
1274+
submitFailingBlock ::
1275+
( HasCallStack
1276+
, ShelleyEraImp era
1277+
, ToExpr (PredicateFailure (EraRule "BBODY" era))
1278+
, NFData (PredicateFailure (EraRule "BBODY" era))
1279+
, ToExpr (Block BHeaderView era)
1280+
, NFData (Block BHeaderView era)
1281+
) =>
1282+
[Tx TopTx era] ->
1283+
NonEmpty (PredicateFailure (EraRule "BBODY" era)) ->
1284+
ImpTestM era ()
1285+
submitFailingBlock txs = submitFailingBlockM txs . const . pure
1286+
1287+
submitFailingBlockM ::
1288+
( HasCallStack
1289+
, ShelleyEraImp era
1290+
, ToExpr (PredicateFailure (EraRule "BBODY" era))
1291+
, NFData (PredicateFailure (EraRule "BBODY" era))
1292+
, ToExpr (Block BHeaderView era)
1293+
, NFData (Block BHeaderView era)
1294+
) =>
1295+
[Tx TopTx era] ->
1296+
(Block BHeaderView era -> ImpTestM era (NonEmpty (PredicateFailure (EraRule "BBODY" era)))) ->
1297+
ImpTestM era ()
1298+
submitFailingBlockM txs mkExpectedFailures = do
1299+
(predFailures, block) <- expectLeftDeepExpr =<< trySubmitBlock txs
1300+
expectedFailures <- mkExpectedFailures block
1301+
predFailures `shouldBeExpr` expectedFailures
1302+
1303+
trySubmitBlock ::
12521304
forall era.
12531305
ShelleyEraImp era =>
12541306
[Tx TopTx era] ->
12551307
ImpTestM
12561308
era
12571309
( Either
1258-
(NonEmpty (PredicateFailure (EraRule "BBODY" era)))
1259-
(State (EraRule "BBODY" era), [Event (EraRule "BBODY" era)])
1310+
(NonEmpty (PredicateFailure (EraRule "BBODY" era)), Block BHeaderView era)
1311+
(Block BHeaderView era)
12601312
)
1261-
tryRunImpBBODY txs = do
1313+
trySubmitBlock txs = do
12621314
let blockBody = mkBasicBlockBody @era & txSeqBlockBodyL .~ SSeq.fromList txs
12631315
nes <- use impNESL
12641316
let ls = nes ^. nesEsL . esLStateL
12651317
pp = nes ^. nesEsL . curPParamsEpochStateL @era
12661318
kh <- freshKeyHash
12671319
slotNo <- use impLastTickG
1268-
let bhView =
1320+
let blockHeader =
12691321
BHeaderView
12701322
{ bhviewID = kh
12711323
, bhviewBSize = fromIntegral $ bBodySize (ProtVer (eraProtVerLow @era) 0) blockBody
12721324
, bhviewHSize = 0
12731325
, bhviewBHash = hashBlockBody blockBody
12741326
, bhviewSlot = slotNo
12751327
}
1276-
tryRunImpRule @"BBODY"
1277-
(BbodyEnv pp (nes ^. chainAccountStateL))
1278-
(BbodyState ls (BlocksMade Map.empty))
1279-
(Block {blockHeader = bhView, blockBody})
1328+
block = Block {blockHeader, blockBody}
1329+
bimap (,block) (const block)
1330+
<$> tryRunImpRule @"BBODY"
1331+
(BbodyEnv pp (nes ^. chainAccountStateL))
1332+
(BbodyState ls (BlocksMade Map.empty))
1333+
block
12801334

12811335
tryRunImpRule ::
12821336
forall rule era.

‎libs/cardano-ledger-core/src/Cardano/Ledger/BHeaderView.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,15 @@
11
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DeriveGeneric #-}
23
{-# LANGUAGE MultiParamTypeClasses #-}
34

45
module Cardano.Ledger.BHeaderView where
56

67
import Cardano.Ledger.BaseTypes (BoundedRational (..), UnitInterval)
78
import Cardano.Ledger.Hashes (EraIndependentBlockBody, HASH, Hash, KeyHash, KeyRole (..))
89
import Cardano.Ledger.Slot (SlotNo (..), (-*))
10+
import Control.DeepSeq (NFData)
911
import Data.Word (Word32)
12+
import GHC.Generics (Generic)
1013

1114
-- | 'BHeaderView' provides an interface between block headers
1215
-- from different Cardano protocols and packages that should be
@@ -30,6 +33,9 @@ data BHeaderView = BHeaderView
3033
, bhviewSlot :: SlotNo
3134
-- ^ The slot for which this block was submitted to the chain.
3235
}
36+
deriving (Generic)
37+
38+
instance NFData BHeaderView
3339

3440
-- | Determine if the given slot is reserved for the overlay schedule.
3541
isOverlaySlot ::

‎libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ import Cardano.Ledger.Binary (
3131
import qualified Cardano.Ledger.Binary.Plain as Plain
3232
import Cardano.Ledger.Core
3333
import Cardano.Ledger.TxIn (TxIn (..))
34+
import Control.DeepSeq (NFData)
3435
import Data.Foldable (toList)
3536
import Data.Set (Set)
3637
import qualified Data.Set as Set
@@ -60,6 +61,8 @@ deriving anyclass instance
6061
) =>
6162
NoThunks (Block h era)
6263

64+
instance (NFData h, NFData (BlockBody era)) => NFData (Block h era)
65+
6366
instance
6467
forall era h.
6568
( Era era

0 commit comments

Comments
 (0)