[WIP] Enrich block bodies to contain Peras certificates

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs

@@ -28,6 +28,7 @@ module Ouroboros.Consensus.Shelley.Eras
 
     -- * Convenience functions
   , isBeforeConway
+  , isBeforeDijkstra
 
     -- * Re-exports
   , StandardCrypto
@@ -140,6 +141,10 @@ isBeforeConway :: forall era. L.Era era => Proxy era -> Bool
 isBeforeConway _ =
   L.eraProtVerLow @era < L.eraProtVerLow @L.ConwayEra
 
+isBeforeDijkstra :: forall era. L.Era era => Proxy era -> Bool
+isBeforeDijkstra _ =
+  L.eraProtVerLow @era < L.eraProtVerLow @L.DijkstraEra
+
 -- | The default implementation of 'applyShelleyBasedTx', a thin wrapper around
 -- 'SL.applyTx'
 defaultApplyShelleyBasedTx ::

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
@@ -26,7 +27,10 @@ module Ouroboros.Consensus.Shelley.Ledger.Block
 
     -- * Shelley Compatibility
   , ShelleyCompatible
+  , fromShelleyBlock
+  , toShelleyBlock
   , mkShelleyBlock
+  , mkShelleyBlockWithPerasCert
   , mkShelleyHeader
 
     -- * Serialisation
@@ -46,22 +50,31 @@ import Cardano.Ledger.Binary
   ( Annotator (..)
   , DecCBOR (..)
   , EncCBOR (..)
+  , EncCBORGroup (..)
   , FullByteString (..)
+  , cborError
+  , decodeListLen
+  , encodeListLen
+  , fromPlainDecoder
   , serialize
   )
 import qualified Cardano.Ledger.Binary.Plain as Plain
 import Cardano.Ledger.Core as SL
-  ( eraDecoder
+  ( EraBlockBody (..)
+  , eraDecoder
   , eraProtVerLow
   , toEraCBOR
   )
-import qualified Cardano.Ledger.Core as SL (TranslationContext, hashBlockBody)
+import qualified Cardano.Ledger.Core as SL (TranslationContext)
 import Cardano.Ledger.Hashes (HASH)
 import qualified Cardano.Ledger.Shelley.API as SL
 import Cardano.Protocol.Crypto (Crypto)
 import qualified Cardano.Protocol.TPraos.BHeader as SL
+import Codec.Serialise (Serialise (..))
+import Control.Arrow (Arrow (..))
 import qualified Data.ByteString.Lazy as Lazy
 import Data.Coerce (coerce)
+import Data.Maybe.Strict (StrictMaybe (..))
 import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks (..))
@@ -145,7 +158,9 @@ instance ShelleyCompatible proto era => ConvertRawHash (ShelleyBlock proto era)
 --
 -- This block is parametrised over both the (ledger) era and the protocol.
 data ShelleyBlock proto era = ShelleyBlock
-  { shelleyBlockRaw :: !(SL.Block (ShelleyProtocolHeader proto) era)
+  { shelleyBlockHeader :: !(ShelleyProtocolHeader proto)
+  , shelleyBlockBody :: !(SL.BlockBody era)
+  , shelleyBlockPerasCert :: !(StrictMaybe (PerasCert (ShelleyBlock proto era)))
   , shelleyBlockHeaderHash :: !ShelleyHash
   }
 
@@ -158,14 +173,46 @@ instance
 
 type instance HeaderHash (ShelleyBlock proto era) = ShelleyHash
 
+-- | Reconstruct a Shelley ledger block from a 'ShelleyBlock'.
+--
+-- TODO: we should be able to avoid this conversion in most cases
+fromShelleyBlock :: ShelleyBlock proto era -> SL.Block (ShelleyProtocolHeader proto) era
+fromShelleyBlock blk = SL.Block (shelleyBlockHeader blk) (shelleyBlockBody blk)
+
+-- | Construct a 'ShelleyBlock' from a Shelley ledger block.
+--
+-- TODO: we should be able to avoid this conversion in most cases
+toShelleyBlock ::
+  ShelleyCompatible proto era => SL.Block (ShelleyProtocolHeader proto) era -> ShelleyBlock proto era
+toShelleyBlock (SL.Block hdr body) = mkShelleyBlock hdr body
+
 mkShelleyBlock ::
   ShelleyCompatible proto era =>
-  SL.Block (ShelleyProtocolHeader proto) era ->
+  ShelleyProtocolHeader proto ->
+  SL.BlockBody era ->
   ShelleyBlock proto era
-mkShelleyBlock raw =
+mkShelleyBlock = mkShelleyBlockGeneric SNothing
+
+mkShelleyBlockWithPerasCert ::
+  ShelleyCompatible proto era =>
+  PerasCert (ShelleyBlock proto era) ->
+  ShelleyProtocolHeader proto ->
+  SL.BlockBody era ->
+  ShelleyBlock proto era
+mkShelleyBlockWithPerasCert = mkShelleyBlockGeneric . SJust
+
+mkShelleyBlockGeneric ::
+  ShelleyCompatible proto era =>
+  StrictMaybe (PerasCert (ShelleyBlock proto era)) ->
+  ShelleyProtocolHeader proto ->
+  BlockBody era ->
+  ShelleyBlock proto era
+mkShelleyBlockGeneric cert header body =
   ShelleyBlock
-    { shelleyBlockRaw = raw
-    , shelleyBlockHeaderHash = pHeaderHash $ SL.bheader raw
+    { shelleyBlockHeader = header
+    , shelleyBlockBody = body
+    , shelleyBlockPerasCert = cert
+    , shelleyBlockHeaderHash = pHeaderHash header
     }
 
 class
@@ -198,10 +245,10 @@ instance
   ShowProxy (Header (ShelleyBlock proto era))
 
 instance ShelleyCompatible proto era => GetHeader (ShelleyBlock proto era) where
-  getHeader (ShelleyBlock rawBlk hdrHash) =
+  getHeader block =
     ShelleyHeader
-      { shelleyHeaderRaw = SL.bheader rawBlk
-      , shelleyHeaderHash = hdrHash
+      { shelleyHeaderRaw = shelleyBlockHeader block
+      , shelleyHeaderHash = shelleyBlockHeaderHash block
       }
 
   blockMatchesHeader hdr blk =
@@ -210,7 +257,7 @@ instance ShelleyCompatible proto era => GetHeader (ShelleyBlock proto era) where
     SL.hashBlockBody blockBody == pHeaderBodyHash shelleyHdr
    where
     ShelleyHeader{shelleyHeaderRaw = shelleyHdr} = hdr
-    ShelleyBlock{shelleyBlockRaw = SL.Block _ blockBody} = blk
+    ShelleyBlock{shelleyBlockBody = blockBody} = blk
 
   headerIsEBB = const Nothing
 
@@ -288,10 +335,35 @@ instance HasNestedContent f (ShelleyBlock proto era)
 
 instance ShelleyCompatible proto era => EncCBOR (ShelleyBlock proto era) where
   -- Don't encode the header hash, we recompute it during deserialisation
-  encCBOR = encCBOR . shelleyBlockRaw
+  encCBOR block = do
+    let header = shelleyBlockHeader block
+    let body = shelleyBlockBody block
+    let bodyLen = listLen body
+    case shelleyBlockPerasCert block of
+      SNothing ->
+        encodeListLen (1 + bodyLen)
+          <> encCBOR header
+          <> encCBORGroup body
+      SJust cert ->
+        encodeListLen (1 + bodyLen + 1)
+          <> encCBOR header
+          <> encCBORGroup body
+          <> encCBOR (encode cert)
 
 instance ShelleyCompatible proto era => DecCBOR (Annotator (ShelleyBlock proto era)) where
-  decCBOR = fmap mkShelleyBlock <$> decCBOR
+  decCBOR = do
+    len <- decodeListLen
+    header <- decCBOR
+    body <- decCBOR
+    cert <- decMaybeCertOrFail len
+    pure $ mkShelleyBlockGeneric <$> cert <*> header <*> body
+   where
+    bodyLen = fromIntegral (numSegComponents @era)
+
+    decMaybeCertOrFail len
+      | len == 1 + bodyLen = pure <$> pure SNothing
+      | len == 1 + bodyLen + 1 = pure <$> (SJust <$> fromPlainDecoder decode)
+      | otherwise = cborError $ Plain.DecoderErrorCustom "ShelleyBlock" "invalid number of elements"
 
 instance ShelleyCompatible proto era => EncCBOR (Header (ShelleyBlock proto era)) where
   -- Don't encode the header hash, we recompute it during deserialisation
@@ -342,7 +414,7 @@ decodeShelleyHeader = eraDecoder @era $ (. Full) . runAnnotator <$> decCBOR
 -------------------------------------------------------------------------------}
 
 instance ShelleyCompatible proto era => Condense (ShelleyBlock proto era) where
-  condense = show . shelleyBlockRaw
+  condense = show . ((shelleyBlockHeader &&& shelleyBlockBody) &&& shelleyBlockPerasCert)
 
 instance ShelleyCompatible proto era => Condense (Header (ShelleyBlock proto era)) where
   condense = show . shelleyHeaderRaw

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs

@@ -8,7 +8,7 @@ module Ouroboros.Consensus.Shelley.Ledger.Forge (forgeShelleyBlock) where
 
 import qualified Cardano.Ledger.Core as Core (Tx)
 import qualified Cardano.Ledger.Core as SL (hashBlockBody, mkBasicBlockBody, txSeqBlockBodyL)
-import qualified Cardano.Ledger.Shelley.API as SL (Block (..), extractTx)
+import qualified Cardano.Ledger.Shelley.API as SL (extractTx)
 import qualified Cardano.Ledger.Shelley.BlockBody as SL (bBodySize)
 import qualified Cardano.Protocol.TPraos.BHeader as SL
 import Control.Exception
@@ -72,7 +72,7 @@ forgeShelleyBlock
         (SL.hashBlockBody @era body)
         actualBodySize
         protocolVersion
-    let blk = mkShelleyBlock $ SL.Block hdr body
+    let blk = mkShelleyBlock hdr body
     return $
       assert (verifyBlockIntegrity (configSlotsPerKESPeriod $ configConsensus cfg) blk) $
         blk

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs

@@ -93,7 +93,7 @@ import qualified Codec.CBOR.Decoding as CBOR
 import Codec.CBOR.Encoding (Encoding)
 import qualified Codec.CBOR.Encoding as CBOR
 import Codec.Serialise (decode, encode)
-import Control.Arrow (left, second)
+import Control.Arrow (Arrow (..), left, second)
 import qualified Control.Exception as Exception
 import Control.Monad.Except
 import qualified Control.State.Transition.Extended as STS
@@ -588,7 +588,7 @@ instance
     LedgerTables
       . KeysMK
       . Core.neededTxInsForBlock
-      . shelleyBlockRaw
+      . fromShelleyBlock
 
 data ShelleyReapplyException
   = forall era.
@@ -632,10 +632,7 @@ applyHelper f cfg blk stBefore = do
     f
       globals
       tickedShelleyLedgerState
-      ( let b = shelleyBlockRaw blk
-            h' = mkHeaderView (SL.bheader b)
-         in SL.Block h' (SL.bbody b)
-      )
+      (SL.Block (mkHeaderView (shelleyBlockHeader blk)) (shelleyBlockBody blk))
 
   let track ::
         LedgerState (ShelleyBlock proto era) ValuesMK ->

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs

@@ -218,7 +218,7 @@ instance ShelleyBasedEra era => HasTxs (ShelleyBlock proto era) where
     map mkShelleyTx
       . blockBodyToTxList
       . SL.bbody
-      . shelleyBlockRaw
+      . fromShelleyBlock
    where
     blockBodyToTxList :: BlockBody era -> [Tx era]
     blockBodyToTxList blockBody = toList $ blockBody ^. txSeqBlockBodyL

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Shelley.hs

@@ -61,16 +61,17 @@ instance
   ) =>
   HasAnalysis (ShelleyBlock proto era)
   where
-  countTxOutputs blk = case Shelley.shelleyBlockRaw blk of
-    SL.Block _ body -> getSum $ foldMap (Sum . countOutputs) (body ^. Core.txSeqBlockBodyL)
+  countTxOutputs blk =
+    getSum $ foldMap (Sum . countOutputs) (Shelley.shelleyBlockBody blk ^. Core.txSeqBlockBodyL)
    where
     countOutputs :: Core.Tx era -> Int
     countOutputs tx = length $ tx ^. Core.bodyTxL . Core.outputsTxBodyL
 
-  blockTxSizes blk = case Shelley.shelleyBlockRaw blk of
-    SL.Block _ body ->
-      toList $
-        fmap (fromIntegral @Integer @SizeInBytes . view Core.sizeTxF) (body ^. Core.txSeqBlockBodyL)
+  blockTxSizes blk =
+    toList $
+      fmap
+        (fromIntegral @Integer @SizeInBytes . view Core.sizeTxF)
+        (Shelley.shelleyBlockBody blk ^. Core.txSeqBlockBodyL)
 
   knownEBBs = const Map.empty
 
@@ -100,8 +101,7 @@ instance
          ]
    where
     txs :: StrictSeq (Core.Tx era)
-    txs = case Shelley.shelleyBlockRaw blk of
-      SL.Block _ body -> body ^. Core.txSeqBlockBodyL
+    txs = Shelley.shelleyBlockBody blk ^. Core.txSeqBlockBodyL
 
   -- For the time being we do not support any block application
   -- metrics for Shelley-only eras.