Generalise Shelley ledger over TxSeq/TxInBlock.

The previous commits introduced the `SupportsSegWit` abstraction, but
did not make use of it. This commit modifies Shelley to make use of it,
with the following changes:

- We add appropriate constraints on `TxInBlock` to `WellFormed`.
- We realise we need to add an additional function to `SupportsSegWit`:
  `hashTxSeq`. This is not the regular hash function, since the block
  body uses a small Merkle tree in its hash.
- Since the hash is now declared in `SupportsSegWit`, we drop the
  `BBodyHash` type. The normal Hash type already includes a type
  specifier, so having the newtype offers us little extra.
- STS systems in general now rely on `TxInBlock` for the signal when
  applying transactions from a block.
- The block decoding is modified to rely on `FromCBOR` for `Era.TxSeq`.
  This means that a small part of code (from `blockDecoder`) is now
  repeated, since it supports an additional flag in order to support
  `LaxBlock`. Since `LaxBlock` is a purely testing concern, we expect to
  remove it from the library entirely.
- Some functions (`bbody`, `bheader`) etc are not modified to use the
  underlying `Block'` type, rather than the `Block` pattern, in order to
  avoid bringing in serialisation constraints.
- Tests, as always, need to be massaged to keep working.

cardano-ledger-core/src/Cardano/Ledger/Era.hs

@@ -32,6 +32,7 @@ import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Crypto as CryptoClass
 import Cardano.Ledger.Hashes
   ( EraIndependentAuxiliaryData,
+    EraIndependentBlockBody,
     EraIndependentTxBody,
     ScriptHash (..),
   )
@@ -80,7 +81,7 @@ class
   ValidateScript era
   where
   scriptPrefixTag :: Core.Script era -> BS.ByteString
-  validateScript :: Core.Script era -> Core.Tx era -> Bool
+  validateScript :: Core.Script era -> TxInBlock era -> Bool
   hashScript :: Core.Script era -> ScriptHash (Crypto era)
   -- ONE SHOULD NOT OVERIDE THE hashScript DEFAULT METHOD
   -- UNLESS YOU UNDERSTAND THE SafeToHash class, AND THE ROLE OF THE scriptPrefixTag
@@ -125,6 +126,13 @@ class SupportsSegWit era where
   fromTxSeq :: TxSeq era -> StrictSeq (TxInBlock era)
   toTxSeq :: StrictSeq (TxInBlock era) -> TxSeq era
 
+  -- | Get the block body hash from the TxSeq. Note that this is not a regular
+  -- "hash the stored bytes" function since the block body hash forms a small
+  -- Merkle tree.
+  hashTxSeq ::
+    TxSeq era ->
+    Hash.Hash (CryptoClass.HASH (Crypto era)) EraIndependentBlockBody
+
 --------------------------------------------------------------------------------
 -- Era translation
 --------------------------------------------------------------------------------
@@ -226,12 +234,12 @@ type WellFormed era =
     HasField "txfee" (Core.TxBody era) Coin,
     HasField "minted" (Core.TxBody era) (Set (ScriptHash (Crypto era))),
     HasField "adHash" (Core.TxBody era) (StrictMaybe (AuxiliaryDataHash (Crypto era))),
-    -- Tx
-    HasField "body" (Core.Tx era) (Core.TxBody era),
-    HasField "wits" (Core.Tx era) (Core.Witnesses era),
-    HasField "auxiliaryData" (Core.Tx era) (StrictMaybe (Core.AuxiliaryData era)),
-    HasField "txsize" (Core.Tx era) Integer,
-    HasField "scriptWits" (Core.Tx era) (Map (ScriptHash (Crypto era)) (Core.Script era)),
+    -- TxInBlock
+    HasField "body" (TxInBlock era) (Core.TxBody era),
+    HasField "wits" (TxInBlock era) (Core.Witnesses era),
+    HasField "auxiliaryData" (TxInBlock era) (StrictMaybe (Core.AuxiliaryData era)),
+    HasField "txsize" (TxInBlock era) Integer,
+    HasField "scriptWits" (TxInBlock era) (Map (ScriptHash (Crypto era)) (Core.Script era)),
     -- TxOut
     HasField "value" (Core.TxOut era) (Core.Value era),
     -- HashAnnotated

shelley-ma/impl/src/Cardano/Ledger/ShelleyMA.hs

@@ -57,6 +57,7 @@ import Data.Typeable (Typeable)
 import GHC.Records (HasField (..))
 import qualified Shelley.Spec.Ledger.BlockChain as Shelley
   ( TxSeq (..),
+    bbHash,
     txSeqTxns,
   )
 import Shelley.Spec.Ledger.Keys (KeyRole (Witness))
@@ -190,6 +191,7 @@ instance
   type TxSeq (ShelleyMAEra ma c) = Shelley.TxSeq (ShelleyMAEra ma c)
   fromTxSeq = Shelley.txSeqTxns
   toTxSeq = Shelley.TxSeq
+  hashTxSeq = Shelley.bbHash
 
 instance
   ( CryptoClass.Crypto c,

shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs

@@ -12,7 +12,7 @@
 module Cardano.Ledger.ShelleyMA.Rules.Utxow where
 
 import qualified Cardano.Ledger.Core as Core
-import Cardano.Ledger.Era (Era (Crypto))
+import Cardano.Ledger.Era (Era (Crypto), TxInBlock)
 import Cardano.Ledger.ShelleyMA.Rules.Utxo (UTXO, UtxoPredicateFailure)
 import Cardano.Ledger.ShelleyMA.TxBody ()
 import Control.State.Transition.Extended
@@ -27,7 +27,7 @@ import Shelley.Spec.Ledger.STS.Utxow
     UtxowPredicateFailure (..),
     shelleyStyleWitness,
   )
-import Shelley.Spec.Ledger.Tx (Tx, WitnessSet)
+import Shelley.Spec.Ledger.Tx (WitnessSet)
 
 -- ==============================================================================
 --   We want to reuse the same rules for Mary and Allegra. We accomplish this
@@ -52,14 +52,14 @@ instance
     Embed (Core.EraRule "UTXO" era) (UTXOW era),
     Environment (Core.EraRule "UTXO" era) ~ UtxoEnv era,
     State (Core.EraRule "UTXO" era) ~ UTxOState era,
-    Signal (Core.EraRule "UTXO" era) ~ Tx era,
+    Signal (Core.EraRule "UTXO" era) ~ TxInBlock era,
     -- Supply the HasField and Validate instances for Mary and Allegra (which match Shelley)
     ShelleyStyleWitnessNeeds era
   ) =>
   STS (UTXOW era)
   where
   type State (UTXOW era) = UTxOState era
-  type Signal (UTXOW era) = Tx era
+  type Signal (UTXOW era) = TxInBlock era
   type Environment (UTXOW era) = UtxoEnv era
   type BaseM (UTXOW era) = ShelleyBase
   type

shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Pretty.hs

@@ -800,8 +800,7 @@ instance PrettyA (Metadata era) where prettyA = ppMetadata
 ppTx ::
   ( PrettyA (Core.TxBody era),
     PrettyA (Core.AuxiliaryData era),
-    PrettyA (Core.Witnesses era),
-    Era era
+    PrettyA (Core.Witnesses era)
   ) =>
   Tx era ->
   PDoc

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

@@ -46,6 +46,7 @@ import Cardano.Ledger.Shelley.Constraints
   )
 import qualified Data.ByteString as BS
 import Data.Proxy
+import Shelley.Spec.Ledger.BlockChain (bbHash)
 import qualified Shelley.Spec.Ledger.BlockChain as Shelley
   ( TxSeq (..),
     txSeqTxns,
@@ -115,6 +116,7 @@ instance CryptoClass.Crypto c => SupportsSegWit (ShelleyEra c) where
   type TxSeq (ShelleyEra c) = Shelley.TxSeq (ShelleyEra c)
   fromTxSeq = Shelley.txSeqTxns
   toTxSeq = Shelley.TxSeq
+  hashTxSeq = bbHash
 
 instance CryptoClass.Crypto c => ValidateAuxiliaryData (ShelleyEra c) c where
   validateAuxiliaryData (Metadata m) = all validMetadatum m

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

@@ -27,7 +27,6 @@ import Shelley.Spec.Ledger.BlockChain as X
   ( BHBody (..),
     BHeader (..),
     Block (..),
-    HashBBody (..),
     HashHeader (..),
     LaxBlock (..),
     PrevHash (..),

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

@@ -33,8 +33,8 @@ module Shelley.Spec.Ledger.BlockChain
     Block (Block, Block'),
     LaxBlock (..),
     TxSeq (TxSeq, txSeqTxns', TxSeq'),
+    constructMetadata,
     txSeqTxns,
-    HashBBody (..),
     bhHash,
     bbHash,
     hashHeaderToNonce,
@@ -85,6 +85,7 @@ import qualified Cardano.Crypto.VRF as VRF
 import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Crypto as CC
 import Cardano.Ledger.Era (Crypto, Era, ValidateScript (..))
+import qualified Cardano.Ledger.Era as Era
 import Cardano.Ledger.Hashes (EraIndependentBlockBody)
 import Cardano.Ledger.SafeHash (SafeToHash (..))
 import Cardano.Slotting.Slot (WithOrigin (..))
@@ -281,17 +282,6 @@ instance
   listLen _ = 3
   listLenBound _ = 3
 
--- | Hash of block body
-newtype HashBBody crypto = UnsafeHashBBody
-  { unHashBody :: (Hash crypto EraIndependentBlockBody)
-  }
-  deriving stock (Show, Eq, Ord)
-  deriving newtype (NoThunks)
-
-deriving newtype instance CC.Crypto crypto => ToCBOR (HashBBody crypto)
-
-deriving newtype instance CC.Crypto crypto => FromCBOR (HashBBody crypto)
-
 -- | Hash a given block header
 bhHash ::
   forall crypto.
@@ -305,9 +295,9 @@ bbHash ::
   forall era.
   (Era era) =>
   TxSeq era ->
-  HashBBody (Crypto era)
+  Hash (Crypto era) EraIndependentBlockBody
 bbHash (TxSeq' _ bodies wits md) =
-  (UnsafeHashBBody . coerce) $
+  coerce $
     hashStrict
       ( hashPart bodies
           <> hashPart wits
@@ -329,13 +319,20 @@ data BHeader crypto = BHeader'
   }
   deriving (Generic)
 
-deriving via AllowThunksIn '["bHeaderBytes"] (BHeader crypto) instance CC.Crypto crypto => NoThunks (BHeader crypto)
+deriving via
+  AllowThunksIn '["bHeaderBytes"] (BHeader crypto)
+  instance
+    CC.Crypto crypto => NoThunks (BHeader crypto)
 
 deriving instance CC.Crypto crypto => Eq (BHeader crypto)
 
 deriving instance CC.Crypto crypto => Show (BHeader crypto)
 
-pattern BHeader :: CC.Crypto crypto => BHBody crypto -> SignedKES crypto (BHBody crypto) -> BHeader crypto
+pattern BHeader ::
+  CC.Crypto crypto =>
+  BHBody crypto ->
+  SignedKES crypto (BHBody crypto) ->
+  BHeader crypto
 pattern BHeader bHeaderBody' bHeaderSig' <-
   BHeader' {bHeaderBody', bHeaderSig'}
   where
@@ -357,7 +354,7 @@ instance
   encodedSizeExpr size proxy =
     1
       + encodedSizeExpr size (bHeaderBody' <$> proxy)
-      + KES.encodedSigKESSizeExpr ((KES.getSig . bHeaderSig') <$> proxy)
+      + KES.encodedSigKESSizeExpr (KES.getSig . bHeaderSig' <$> proxy)
 
 instance
   CC.Crypto crypto =>
@@ -470,7 +467,7 @@ data BHBody crypto = BHBody
     -- | Size of the block body
     bsize :: !Natural,
     -- | Hash of block body
-    bhash :: !(HashBBody crypto),
+    bhash :: !(Hash crypto EraIndependentBlockBody),
     -- | operational certificate
     bheaderOCert :: !(OCert crypto),
     -- | protocol version
@@ -522,7 +519,7 @@ instance
       + VRF.encodedVerKeyVRFSizeExpr (bheaderVrfVk <$> proxy)
       + encodedSizeExpr size (bheaderEta <$> proxy)
       + encodedSizeExpr size (bheaderL <$> proxy)
-      + encodedSizeExpr size ((toWord64 . bsize) <$> proxy)
+      + encodedSizeExpr size (toWord64 . bsize <$> proxy)
       + encodedSizeExpr size (bhash <$> proxy)
       + encodedSizeExpr size (bheaderOCert <$> proxy)
       + encodedSizeExpr size (bprotver <$> proxy)
@@ -581,22 +578,26 @@ bnonce :: BHBody crypto -> Nonce
 bnonce = mkNonceFromOutputVRF . VRF.certifiedOutput . bheaderEta
 
 data Block era
-  = Block' !(BHeader (Crypto era)) !(TxSeq era) BSL.ByteString
+  = Block' !(BHeader (Crypto era)) !(Era.TxSeq era) BSL.ByteString
   deriving (Generic)
 
 deriving stock instance
-  (Era era, Show (Core.Tx era)) =>
+  (Era era, Show (Era.TxSeq era)) =>
   Show (Block era)
 
 deriving stock instance
-  (Era era, Eq (Core.Tx era)) =>
+  (Era era, Eq (Era.TxSeq era)) =>
   Eq (Block era)
 
 deriving anyclass instance
-  (Era era, NoThunks (Core.Tx era)) =>
+  (Era era, NoThunks (Era.TxSeq era)) =>
   NoThunks (Block era)
 
-pattern Block :: (Era era) => BHeader (Crypto era) -> TxSeq era -> Block era
+pattern Block ::
+  (Era era, ToCBORGroup (Era.TxSeq era)) =>
+  BHeader (Crypto era) ->
+  Era.TxSeq era ->
+  Block era
 pattern Block h txns <-
   Block' h txns _
   where
@@ -615,8 +616,8 @@ constructMetadata ::
   forall era.
   Int ->
   Map Int (Annotator (Core.AuxiliaryData era)) ->
-  (Seq (Maybe (Annotator (Core.AuxiliaryData era))))
-constructMetadata n md = (fmap (`Map.lookup` md) (Seq.fromList [0 .. n -1]))
+  Seq (Maybe (Annotator (Core.AuxiliaryData era)))
+constructMetadata n md = fmap (`Map.lookup` md) (Seq.fromList [0 .. n -1])
 
 instance
   Era era =>
@@ -635,18 +636,6 @@ type BlockAnn era =
     ToCBOR (Core.Witnesses era)
   )
 
-blockDecoder ::
-  ( BlockAnn era,
-    ValidateScript era
-  ) =>
-  Bool ->
-  forall s. Decoder s (Annotator (Block era))
-blockDecoder lax = annotatorSlice $
-  decodeRecordNamed "Block" (const 4) $ do
-    header <- fromCBOR
-    txns <- txSeqDecoder lax
-    pure $ Block' <$> header <*> txns
-
 -- | Decode a TxSeq, used in decoding a Block.
 txSeqDecoder ::
   forall era.
@@ -683,27 +672,55 @@ txSeqDecoder lax = do
             Seq.zipWith3 segwitTx bodies wits metadata
   pure $ TxSeq' <$> txns <*> bodiesAnn <*> witsAnn <*> metadataAnn
 
+instance
+  (BlockAnn era, Typeable era) =>
+  FromCBOR (Annotator (TxSeq era))
+  where
+  fromCBOR = txSeqDecoder False
+
 instance
   ( BlockAnn era,
-    ValidateScript era
+    ValidateScript era,
+    FromCBOR (Annotator (Era.TxSeq era))
   ) =>
   FromCBOR (Annotator (Block era))
   where
-  fromCBOR = blockDecoder False
-
+  fromCBOR = annotatorSlice $
+    decodeRecordNamed "Block" (const 4) $ do
+      header <- fromCBOR
+      txns <- fromCBOR
+      pure $ Block' <$> header <*> txns
+
+-- | A block in which we do not validate the matched encoding of parts of the
+--   segwit. TODO This is purely a test concern, and as such should be moved out
+--   of the library.
 newtype LaxBlock era = LaxBlock (Block era)
 
+blockDecoder ::
+  ( BlockAnn era,
+    ValidateScript era,
+    Era.TxSeq era ~ TxSeq era
+  ) =>
+  Bool ->
+  forall s. Decoder s (Annotator (Block era))
+blockDecoder lax = annotatorSlice $
+  decodeRecordNamed "Block" (const 4) $ do
+    header <- fromCBOR
+    txns <- txSeqDecoder lax
+    pure $ Block' <$> header <*> txns
+
 instance (Era era, Typeable era) => ToCBOR (LaxBlock era) where
   toCBOR (LaxBlock x) = toCBOR x
 
 deriving stock instance
-  (Era era, Show (Core.Tx era)) =>
+  (Era era, Show (Era.TxSeq era)) =>
   Show (LaxBlock era)
 
 instance
   ( Era era,
     BlockAnn era,
-    ValidateScript era
+    ValidateScript era,
+    Era.TxSeq era ~ TxSeq era
   ) =>
   FromCBOR (Annotator (LaxBlock era))
   where
@@ -717,23 +734,19 @@ bHeaderSize ::
 bHeaderSize = BS.length . serialize'
 
 bBodySize ::
-  forall era.
-  (Era era) =>
-  TxSeq era ->
-  Int
+  ToCBORGroup txSeq => txSeq -> Int
 bBodySize = BS.length . serializeEncoding' . toCBORGroup
 
 slotToNonce :: SlotNo -> Nonce
 slotToNonce (SlotNo s) = mkNonceFromNumber s
 
 bheader ::
-  (Era era) =>
   Block era ->
   BHeader (Crypto era)
-bheader (Block bh _) = bh
+bheader (Block' bh _ _) = bh
 
-bbody :: (Era era) => Block era -> TxSeq era
-bbody (Block _ txs) = txs
+bbody :: Block era -> Era.TxSeq era
+bbody (Block' _ txs _) = txs
 
 bhbody ::
   CC.Crypto crypto =>