diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs index 7ad052c9779..a3551d9d608 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs @@ -193,7 +193,7 @@ alonzoBbodyTransition = >>= \( TRC ( BbodyEnv pp account , BbodyState ls b - , UnserialisedBlock bh txsSeq + , Block bh txsSeq ) ) -> do let txs = txSeqTxns txsSeq diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs index f22f764bd6b..f467c162d66 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs @@ -278,7 +278,7 @@ conwayBbodyTransition = do >>= \( TRC ( _ , state@(BbodyState ls _) - , UnserialisedBlock _ txsSeq + , Block _ txsSeq ) ) -> do let utxo = utxosUtxo (lsUTxOState ls) diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs index 74f11c087b7..60dc33709d0 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs @@ -92,7 +92,7 @@ spec = describe "BBODY" $ do tryRunImpRule @"BBODY" (BbodyEnv pp account) (BbodyState ls (BlocksMade Map.empty)) - (UnsafeUnserialisedBlock bhView txSeq) + (Block bhView txSeq) predFailures `shouldBe` NE.fromList [ injectFailure diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs index 48a5b584889..3c7572f5678 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs @@ -179,7 +179,7 @@ bbodyTransition = >>= \( TRC ( BbodyEnv pp account , BbodyState ls b - , UnserialisedBlock bhview txsSeq + , Block bhview txsSeq ) ) -> do let txs = fromTxSeq txsSeq diff --git a/eras/shelley/test-suite/bench/BenchValidation.hs b/eras/shelley/test-suite/bench/BenchValidation.hs index 71dfaadd03a..4eb9c0e9014 100644 --- a/eras/shelley/test-suite/bench/BenchValidation.hs +++ b/eras/shelley/test-suite/bench/BenchValidation.hs @@ -94,7 +94,7 @@ benchValidate :: ValidateInput era -> IO (NewEpochState era) benchValidate (ValidateInput globals state (Block bh txs)) = - let block = UnsafeUnserialisedBlock (makeHeaderView bh) txs + let block = Block (makeHeaderView bh) txs in case API.applyBlockEitherNoEvents ValidateAll globals state block of Right x -> pure x Left x -> error (show x) @@ -112,7 +112,7 @@ applyBlock :: Int -> Int applyBlock (ValidateInput globals state (Block bh txs)) n = - let block = UnsafeUnserialisedBlock (makeHeaderView bh) txs + let block = Block (makeHeaderView bh) txs in case API.applyBlockEitherNoEvents ValidateAll globals state block of Right x -> seq (rnf x) (n + 1) Left x -> error (show x) @@ -122,7 +122,7 @@ benchreValidate :: ValidateInput era -> NewEpochState era benchreValidate (ValidateInput globals state (Block bh txs)) = - API.applyBlockNoValidaton globals state (UnsafeUnserialisedBlock (makeHeaderView bh) txs) + API.applyBlockNoValidaton globals state (Block (makeHeaderView bh) txs) -- ============================================================== diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs index 744e9707983..f19a516397b 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs @@ -11,14 +11,7 @@ module Test.Cardano.Ledger.Shelley.LaxBlock where -import Cardano.Ledger.Binary ( - Annotator (..), - DecCBOR (decCBOR), - Decoder, - ToCBOR, - annotatorSlice, - decodeRecordNamed, - ) +import Cardano.Ledger.Binary import Cardano.Ledger.Block (Block (..)) import Cardano.Ledger.Core (Era, EraSegWits (TxSeq), EraTx) import Cardano.Ledger.Shelley.BlockChain (ShelleyTxSeq, txSeqDecoder) @@ -28,7 +21,13 @@ import Data.Typeable (Typeable) -- encoding of parts of the segwit. -- This is only for testing. newtype LaxBlock h era = LaxBlock (Block h era) - deriving (ToCBOR) + +deriving newtype instance + ( Era era + , EncCBORGroup (TxSeq era) + , EncCBOR h + ) => + ToCBOR (LaxBlock h era) deriving newtype instance ( EraSegWits era @@ -45,11 +44,11 @@ blockDecoder :: Bool -> forall s. Decoder s (Annotator (Block h era)) -blockDecoder lax = annotatorSlice $ +blockDecoder lax = decodeRecordNamed "Block" (const 4) $ do header <- decCBOR txns <- txSeqDecoder lax - pure $ Block' <$> header <*> txns + pure $ Block <$> header <*> txns deriving stock instance (Era era, Show (TxSeq era), Show h) => Show (LaxBlock h era) diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs index b2f4dd10c4a..b765877307f 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs @@ -581,7 +581,7 @@ withdrawals :: EraGen era => Block (BHeader MockCrypto) era -> Coin -withdrawals (UnserialisedBlock _ txseq) = +withdrawals (Block _ txseq) = F.foldl' ( \c tx -> let wdrls = unWithdrawals $ tx ^. bodyTxL . withdrawalsTxBodyL diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs index 7c704263fed..b6e9a326ce9 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs @@ -301,7 +301,6 @@ chainTransition :: , State (EraRule "TICK" era) ~ NewEpochState era , Signal (EraRule "TICK" era) ~ SlotNo , Embed (PRTCL MockCrypto) (CHAIN era) - , EncCBORGroup (TxSeq era) , ProtVerAtMost era 6 , State (EraRule "LEDGERS" era) ~ LedgerState era , EraGov era @@ -370,10 +369,9 @@ chainTransition = , bh ) - let thouShaltNot = error "A block with a header view should never be hashed" BbodyState ls' bcur' <- trans @(EraRule "BBODY" era) $ - TRC (BbodyEnv pp' account, BbodyState ls bcur, Block' bhView txs thouShaltNot) + TRC (BbodyEnv pp' account, BbodyState ls bcur, Block bhView txs) let nes'' = updateNES nes' bcur' ls' bhb = bhbody bh diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs index 3443fbedabc..24aa3aa8873 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs @@ -137,7 +137,7 @@ relevantCasesAreCoveredForTrace :: Property relevantCasesAreCoveredForTrace tr = do let blockTxs :: Block (BHeader MockCrypto) era -> [Tx era] - blockTxs (UnserialisedBlock _ txSeq) = toList (fromTxSeq @era txSeq) + blockTxs (Block _ txSeq) = toList (fromTxSeq @era txSeq) bs = traceSignals OldestFirst tr txs = concat (blockTxs <$> bs) certsByTx_ = certsByTx @era txs diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/PoolReap.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/PoolReap.hs index dcd00ea455d..3b29d1db6c2 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/PoolReap.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/PoolReap.hs @@ -80,7 +80,7 @@ tests = poolState target = (chainNes target) ^. nesEsL . esLStateL . lsCertStateL . certPStateL removedAfterPoolreap_ :: SourceSignalTarget (CHAIN era) -> Property - removedAfterPoolreap_ (SourceSignalTarget {source, target, signal = (UnserialisedBlock bh _)}) = + removedAfterPoolreap_ (SourceSignalTarget {source, target, signal = (Block bh _)}) = let e = (epochFromSlotNo . bheaderSlotNo . bhbody) bh in removedAfterPoolreap (poolState source) (poolState target) e diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs index a5cf23663e7..39c7b8e6698 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs @@ -254,7 +254,7 @@ ledgerTraceBase chainSt block = , txs ) where - (UnserialisedBlock (BHeader bhb _) txSeq) = block + (Block (BHeader bhb _) txSeq) = block slot = bheaderSlotNo bhb tickedChainSt = tickChainState slot chainSt nes = (nesEs . chainNes) tickedChainSt diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs index 9df716f2f2f..9309d0735c2 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs @@ -987,7 +987,7 @@ tests = in checkEncodingCBORAnnotated shelleyProtVer "empty_block" - (Block @C bh txns) + (Block @(BHeader MockCrypto) @C bh txns) ( (T $ TkListLen 4) <> S bh <> T (TkListLen 0 . TkListLen 0 . TkMapLen 0) @@ -1048,7 +1048,7 @@ tests = in checkEncodingCBORAnnotated shelleyProtVer "rich_block" - (Block @C bh txns) + (Block @(BHeader MockCrypto) @C bh txns) ( (T $ TkListLen 4) -- header <> S bh diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index bb01c85ce59..6bac6e3ee52 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,9 @@ ## 1.17.0.0 +* Replace `Block'` constructor with `Block` +* Remove patterns: `Block`, `UnserialisedBlock` and `UnsafeUnserialisedBlock` +* Add ` EncCBORGroup (TxSeq era)` and `EncCBOR h` constraints to `EncCBOR` and `ToCBOR` instances for `Block` * Add `BoootstrapWitnessRaw` type * Add `EraStake`, `CanGetInstantStake`, `CanSetInstantStake` , `snapShotFromInstantStake`, `resolveActiveInstantStakeCredentials` * Add boolean argument to `fromCborRigorousBothAddr` for lenient `Ptr` decoding diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs index 1f9ebcd175a..c80854dc357 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs @@ -15,7 +15,7 @@ {-# LANGUAGE UndecidableInstances #-} module Cardano.Ledger.Block ( - Block (Block, Block', UnserialisedBlock, UnsafeUnserialisedBlock), + Block (Block), bheader, bbody, neededTxInsForBlock, @@ -27,17 +27,13 @@ import Cardano.Ledger.Binary ( DecCBOR (decCBOR), EncCBOR (..), EncCBORGroup (..), - annotatorSlice, decodeRecordNamed, encodeListLen, - serialize, + toPlainEncoding, ) import qualified Cardano.Ledger.Binary.Plain as Plain import Cardano.Ledger.Core -import Cardano.Ledger.MemoBytes (MemoBytes (Memo), decodeMemoized) import Cardano.Ledger.TxIn (TxIn (..)) -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Short as SBS import Data.Foldable (toList) import Data.Set (Set) import qualified Data.Set as Set @@ -47,7 +43,7 @@ import Lens.Micro ((^.)) import NoThunks.Class (NoThunks (..)) data Block h era - = Block' !h !(TxSeq era) BSL.ByteString + = Block !h !(TxSeq era) deriving (Generic) deriving stock instance @@ -65,111 +61,63 @@ deriving anyclass instance ) => NoThunks (Block h era) -pattern Block :: +instance forall era h. ( Era era , EncCBORGroup (TxSeq era) , EncCBOR h ) => - h -> - TxSeq era -> - Block h era -pattern Block h txns <- - Block' h txns _ - where - Block h txns = - let bytes = - serialize (eraProtVerLow @era) $ - encodeListLen (1 + listLen txns) <> encCBOR h <> encCBORGroup txns - in Block' h txns bytes - -{-# COMPLETE Block #-} - --- | Access a block without its serialised bytes. This is often useful when --- we're using a 'BHeaderView' in place of the concrete header. -pattern UnserialisedBlock :: - h -> - TxSeq era -> - Block h era -pattern UnserialisedBlock h txns <- Block' h txns _ - -{-# COMPLETE UnserialisedBlock #-} - --- | Unsafely construct a block without the ability to serialise its bytes. --- --- Anyone calling this pattern must ensure that the resulting block is never --- serialised. Any uses of this pattern outside of testing code should be --- regarded with suspicion. -pattern UnsafeUnserialisedBlock :: - h -> - TxSeq era -> - Block h era -pattern UnsafeUnserialisedBlock h txns <- - Block' h txns _ + EncCBOR (Block h era) where - UnsafeUnserialisedBlock h txns = - let bytes = error "`UnsafeUnserialisedBlock` used to construct a block which was later serialised." - in Block' h txns bytes - -{-# COMPLETE UnsafeUnserialisedBlock #-} - -instance (EraTx era, Typeable h) => EncCBOR (Block h era) - -instance (EraTx era, Typeable h) => Plain.ToCBOR (Block h era) where - toCBOR (Block' _ _ blockBytes) = Plain.encodePreEncoded $ BSL.toStrict blockBytes + encCBOR (Block h txns) = + encodeListLen (1 + listLen txns) <> encCBOR h <> encCBORGroup txns instance - ( EraSegWits era - , DecCBOR (Annotator h) - , Typeable h + forall era h. + ( Era era + , EncCBORGroup (TxSeq era) + , EncCBOR h ) => - DecCBOR (Annotator (Block h era)) + Plain.ToCBOR (Block h era) where - decCBOR = annotatorSlice $ - decodeRecordNamed "Block" (const blockSize) $ do - header <- decCBOR - txns <- decCBOR - pure $ Block' <$> header <*> txns - where - blockSize = - 1 -- header - + fromIntegral (numSegComponents @era) - -data BlockRaw h era = BlockRaw !h !(TxSeq era) + toCBOR = toPlainEncoding (eraProtVerLow @era) . encCBOR instance ( EraSegWits era , DecCBOR h , DecCBOR (TxSeq era) ) => - DecCBOR (BlockRaw h era) + DecCBOR (Block h era) where decCBOR = decodeRecordNamed "Block" (const blockSize) $ do header <- decCBOR txns <- decCBOR - pure $ BlockRaw header txns + pure $ Block header txns where blockSize = 1 + fromIntegral (numSegComponents @era) instance ( EraSegWits era - , DecCBOR h - , DecCBOR (TxSeq era) + , DecCBOR (Annotator h) + , Typeable h ) => - DecCBOR (Block h era) + DecCBOR (Annotator (Block h era)) where - decCBOR = do - Memo (BlockRaw h txSeq) bs <- decodeMemoized (decCBOR @(BlockRaw h era)) - pure $ Block' h txSeq (BSL.fromStrict (SBS.fromShort bs)) + decCBOR = decodeRecordNamed "Block" (const blockSize) $ do + header <- decCBOR + txns <- decCBOR + pure $ Block <$> header <*> txns + where + blockSize = 1 + fromIntegral (numSegComponents @era) bheader :: Block h era -> h -bheader (Block' bh _ _) = bh +bheader (Block bh _) = bh bbody :: Block h era -> TxSeq era -bbody (Block' _ txs _) = txs +bbody (Block _ txs) = txs -- | The validity of any individual block depends only on a subset -- of the UTxO stored in the ledger state. This function returns @@ -185,7 +133,7 @@ neededTxInsForBlock :: EraSegWits era => Block h era -> Set TxIn -neededTxInsForBlock (Block' _ txsSeq _) = Set.filter isNotNewInput allTxIns +neededTxInsForBlock (Block _ txsSeq) = Set.filter isNotNewInput allTxIns where txBodies = map (^. bodyTxL) $ toList $ fromTxSeq txsSeq allTxIns = Set.unions $ map (^. allInputsTxBodyF) txBodies diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs index ca2e1576910..18326e711b7 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs @@ -705,7 +705,7 @@ coldKeys = KeyPair vk sk makeNaiveBlock :: forall era. EraSegWits era => [Tx era] -> Block BHeaderView era -makeNaiveBlock txs = UnsafeUnserialisedBlock bhView txSeq +makeNaiveBlock txs = Block bhView txSeq where bhView = BHeaderView diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs index bd048e6eee2..8d98f313f8a 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs @@ -247,7 +247,7 @@ instance Same era (ShelleyLedgerExamples era) where same proof x1 x2 = case (sleBlock x1, sleBlock x2) of - (Block' h1 a1 _, Block' h2 a2 _) -> + (Block h1 a1, Block h2 a2) -> sameWithDependency [ SomeM "Tx" (sameTx proof) (sleTx x1) (sleTx x2) , SomeM "TxSeq" (sameTxSeq proof) a1 a2 diff --git a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/Binary/RoundTrip.hs b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/Binary/RoundTrip.hs index 438ab6b63f1..79db58fc4e7 100644 --- a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/Binary/RoundTrip.hs +++ b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/Binary/RoundTrip.hs @@ -6,7 +6,7 @@ module Test.Cardano.Protocol.Binary.RoundTrip (roundTripBlockSpec) where -import Cardano.Ledger.Binary (Annotator, DecCBOR) +import Cardano.Ledger.Binary (Annotator, DecCBOR, EncCBOR) import Cardano.Ledger.Block (Block) import Cardano.Ledger.Core import Data.Typeable @@ -20,6 +20,7 @@ roundTripBlockSpec :: , Show h , DecCBOR h , DecCBOR (Annotator h) + , EncCBOR h , EraSegWits era , DecCBOR (TxSeq era) , Arbitrary (Block h era)