NOT MERGE: Leios prototype remake

eras/dijkstra/impl/cardano-ledger-dijkstra.cabal

@@ -236,6 +236,7 @@ test-suite tests
   other-modules:
     Paths_cardano_ledger_dijkstra
     Test.Cardano.Ledger.Dijkstra.Binary.CddlSpec
+    Test.Cardano.Ledger.Dijkstra.BlockBodySpec
     Test.Cardano.Ledger.Dijkstra.GoldenSpec
 
   default-language: Haskell2010
@@ -255,8 +256,9 @@ test-suite tests
     base,
     cardano-ledger-alonzo,
     cardano-ledger-babbage:testlib,
-    cardano-ledger-binary:testlib,
+    cardano-ledger-binary:{cardano-ledger-binary, testlib},
     cardano-ledger-conway:{cardano-ledger-conway, testlib},
     cardano-ledger-core:{cardano-ledger-core, testlib},
     cardano-ledger-dijkstra:{cardano-ledger-dijkstra, cddl, testlib},
     cardano-ledger-shelley:testlib,
+    cardano-strict-containers,

eras/dijkstra/impl/cddl/data/dijkstra.cddl

@@ -5,12 +5,19 @@
 ;      the same
 ;   2) every transaction_index must be strictly smaller than the length of
 ;      transaction_bodies
+; 
+; The 'leios_cert' and 'peras_cert' slots are always present on the wire and
+; encode as CBOR null when absent. Two slots in a row can't be wire-disambiguated
+; as trailing-optionals (the prototype's [4-or-5-item-body] pattern), so the body
+; has a fixed item count and the slots themselves are nullable.
 block = 
   [ header                 
   , transaction_bodies       : [* transaction_body]                   
   , transaction_witness_sets : [* transaction_witness_set]            
   , auxiliary_data_set       : {* transaction_index => auxiliary_data}
   , invalid_transactions     : [* transaction_index]                  
+  , leios_cert               : leios_cert/ nil                            
+  , peras_cert               : peras_cert/ nil                            
   ]
 
 
@@ -805,3 +812,13 @@ auxiliary_data_map =
 
 transaction_index = uint .size 2
 
+; Placeholder Leios certificate. The real cert payload will be filled in
+; once the Leios design lands; for now it serialises as an empty CBOR list
+; so the on-wire token is unambiguous against the surrounding 'null /
+; leios_cert' choice.
+leios_cert = []
+
+; Placeholder Peras certificate. Same shape as 'leios_cert' (empty CBOR
+; list) until the Peras design fixes the payload.
+peras_cert = []
+

eras/dijkstra/impl/cddl/lib/Cardano/Ledger/Dijkstra/HuddleSpec.hs

@@ -863,6 +863,11 @@ instance HuddleRule "block" DijkstraEra where
           |     the same
           |  2) every transaction_index must be strictly smaller than the length of
           |     transaction_bodies
+          |
+          |The 'leios_cert' and 'peras_cert' slots are always present on the wire and
+          |encode as CBOR null when absent. Two slots in a row can't be wire-disambiguated
+          |as trailing-optionals (the prototype's [4-or-5-item-body] pattern), so the body
+          |has a fixed item count and the slots themselves are nullable.
           |]
       $ pname
         =.= arr
@@ -876,8 +881,28 @@ instance HuddleRule "block" DijkstraEra where
                     ==> huddleRule @"auxiliary_data" p
                 ]
           , "invalid_transactions" ==> arr [0 <+ a (huddleRule @"transaction_index" p)]
+          , "leios_cert" ==> huddleRule @"leios_cert" p / VNil
+          , "peras_cert" ==> huddleRule @"peras_cert" p / VNil
           ]
 
+instance HuddleRule "leios_cert" DijkstraEra where
+  huddleRuleNamed pname _p =
+    comment
+      [str|Placeholder Leios certificate. The real cert payload will be filled in
+          |once the Leios design lands; for now it serialises as an empty CBOR list
+          |so the on-wire token is unambiguous against the surrounding 'null /
+          |leios_cert' choice.
+          |]
+      $ pname =.= arr []
+
+instance HuddleRule "peras_cert" DijkstraEra where
+  huddleRuleNamed pname _p =
+    comment
+      [str|Placeholder Peras certificate. Same shape as 'leios_cert' (empty CBOR
+          |list) until the Peras design fixes the payload.
+          |]
+      $ pname =.= arr []
+
 instance HuddleRule "auxiliary_scripts" DijkstraEra where
   huddleRuleNamed = auxiliaryScriptsRule
 

eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/BlockBody/Internal.hs

@@ -30,19 +30,21 @@ module Cardano.Ledger.Dijkstra.BlockBody.Internal (
   alignedValidFlags,
   mkBasicBlockBodyDijkstra,
   DijkstraEraBlockBody (..),
+  LeiosCert,
 ) where
 
 import qualified Cardano.Crypto.Hash as Hash
 import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..), IsValid (..))
-import Cardano.Ledger.BaseTypes (PerasCert)
+import Cardano.Ledger.BaseTypes (LeiosCert, PerasCert)
 import Cardano.Ledger.Binary (
   Annotator (..),
   DecCBOR (..),
   EncCBORGroup (..),
-  decodeListLen,
+  decodeNullStrictMaybe,
   encCBOR,
   encodeFoldableEncoder,
   encodeFoldableMapEncoder,
+  encodeNullStrictMaybe,
   encodePreEncoded,
   serialize,
   withSlice,
@@ -53,7 +55,6 @@ import Cardano.Ledger.Dijkstra.Tx ()
 import Cardano.Ledger.Shelley.BlockBody (auxDataSeqDecoder)
 import Control.DeepSeq (NFData)
 import Control.Monad (unless)
-import Data.Bifunctor (Bifunctor (..))
 import Data.ByteString (ByteString)
 import Data.ByteString.Builder (Builder, shortByteString, toLazyByteString)
 import qualified Data.ByteString.Lazy as BSL
@@ -84,6 +85,9 @@ import NoThunks.Class (AllowThunksIn (..), NoThunks)
 
 data DijkstraBlockBody era = DijkstraBlockBodyInternal
   { dbbTxs :: !(StrictSeq (Tx TopTx era))
+  , dbbLeiosCert :: !(StrictMaybe LeiosCert)
+  -- ^ Optional Leios certificate. When 'SJust', the EB closure carrying
+  -- the actual transactions must be looked up via the LeiosDB.
   , dbbPerasCert :: !(StrictMaybe PerasCert)
   -- ^ Optional Peras certificate
   , dbbHash :: Hash.Hash HASH EraIndependentBlockBody
@@ -98,81 +102,112 @@ data DijkstraBlockBody era = DijkstraBlockBodyInternal
   , dbbTxsIsValidBytes :: BSL.ByteString
   -- ^ Bytes representing a set of integers. These are the indices of
   -- transactions with 'isValid' == False.
+  , dbbLeiosCertBytes :: Maybe BSL.ByteString
+  -- ^ Bytes encoding the optional Leios certificate
   , dbbPerasCertBytes :: Maybe BSL.ByteString
   -- ^ Bytes encoding the optional Peras certificate
   }
   deriving (Generic)
 
-instance (NFData (Tx TopTx era), NFData PerasCert) => NFData (DijkstraBlockBody era)
+instance
+  (NFData (Tx TopTx era), NFData LeiosCert, NFData PerasCert) =>
+  NFData (DijkstraBlockBody era)
 
 instance EraBlockBody DijkstraEra where
   type BlockBody DijkstraEra = DijkstraBlockBody DijkstraEra
   mkBasicBlockBody = mkBasicBlockBodyDijkstra
-  txSeqBlockBodyL = lens dbbTxs (\bb p -> bb {dbbTxs = p})
+
+  -- Rebuild via the bidirectional pattern so the cached body/wits/aux/isvalid
+  -- bytes and the body hash are recomputed for the new tx sequence. Mirrors
+  -- the Alonzo idiom 'lens abbTxs (\_ s -> AlonzoBlockBody s)'.
+  txSeqBlockBodyL =
+    lens dbbTxs (\bb txs -> DijkstraBlockBody txs (dbbLeiosCert bb) (dbbPerasCert bb))
   hashBlockBody = dbbHash
-  numSegComponents = 5
+  numSegComponents = 6
 
 mkBasicBlockBodyDijkstra ::
   ( SafeToHash (TxWits era)
   , BlockBody era ~ DijkstraBlockBody era
   , AlonzoEraTx era
   ) =>
   BlockBody era
-mkBasicBlockBodyDijkstra = DijkstraBlockBody mempty SNothing
+mkBasicBlockBodyDijkstra = DijkstraBlockBody mempty SNothing SNothing
 {-# INLINEABLE mkBasicBlockBodyDijkstra #-}
 
 -- | Dijkstra-specific extensions to 'EraBlockBody'
 class EraBlockBody era => DijkstraEraBlockBody era where
+  leiosCertBlockBodyL :: Lens' (BlockBody era) (StrictMaybe LeiosCert)
+  -- ^ Lens to access the optional Leios certificate in the block body
+
   perasCertBlockBodyL :: Lens' (BlockBody era) (StrictMaybe PerasCert)
   -- ^ Lens to access the optional Peras certificate in the block body
 
 instance DijkstraEraBlockBody DijkstraEra where
-  perasCertBlockBodyL = lens dbbPerasCert (\bb c -> bb {dbbPerasCert = c})
+  leiosCertBlockBodyL =
+    lens dbbLeiosCert (\bb c -> DijkstraBlockBody (dbbTxs bb) c (dbbPerasCert bb))
+  perasCertBlockBodyL =
+    lens dbbPerasCert (\bb c -> DijkstraBlockBody (dbbTxs bb) (dbbLeiosCert bb) c)
 
 pattern DijkstraBlockBody ::
   forall era.
   ( AlonzoEraTx era
   , SafeToHash (TxWits era)
   ) =>
   StrictSeq (Tx TopTx era) ->
+  StrictMaybe LeiosCert ->
   StrictMaybe PerasCert ->
   DijkstraBlockBody era
-pattern DijkstraBlockBody xs mbPerasCert <-
-  DijkstraBlockBodyInternal xs mbPerasCert _ _ _ _ _ _
+pattern DijkstraBlockBody xs mbLeiosCert mbPerasCert <-
+  DijkstraBlockBodyInternal xs mbLeiosCert mbPerasCert _ _ _ _ _ _ _
   where
-    DijkstraBlockBody txns mbPerasCert =
+    DijkstraBlockBody txns mbLeiosCert mbPerasCert =
       let version = eraProtVerLow @era
           serializeFoldablePreEncoded x =
             serialize version $
               encodeFoldableEncoder encodePreEncoded x
           metaChunk index m = encodeIndexed <$> strictMaybeToMaybe m
             where
               encodeIndexed metadata = encCBOR index <> encodePreEncoded metadata
-          txSeqBodies =
-            serializeFoldablePreEncoded $ originalBytes . view bodyTxL <$> txns
-          txSeqWits =
-            serializeFoldablePreEncoded $ originalBytes . view witsTxL <$> txns
-          txSeqAuxDatas =
-            serialize version . encodeFoldableMapEncoder metaChunk $
-              fmap originalBytes . view auxDataTxL <$> txns
-          txSeqIsValids =
-            serialize version $ encCBOR $ nonValidatingIndices txns
+          -- NOTE: When the block contains a LeiosCert, any transactions must
+          -- not be encoded or contribute to the block body hash.
+          (txSeqBodies, txSeqWits, txSeqAuxDatas, txSeqIsValids) =
+            case mbLeiosCert of
+              SJust _ ->
+                ( serializeFoldablePreEncoded (mempty :: StrictSeq ByteString)
+                , serializeFoldablePreEncoded (mempty :: StrictSeq ByteString)
+                , serialize
+                    version
+                    (encodeFoldableMapEncoder metaChunk (mempty :: StrictSeq (StrictMaybe ByteString)))
+                , serialize version (encCBOR ([] :: [Int]))
+                )
+              SNothing ->
+                ( serializeFoldablePreEncoded $ originalBytes . view bodyTxL <$> txns
+                , serializeFoldablePreEncoded $ originalBytes . view witsTxL <$> txns
+                , serialize version . encodeFoldableMapEncoder metaChunk $
+                    fmap originalBytes . view auxDataTxL <$> txns
+                , serialize version $ encCBOR $ nonValidatingIndices txns
+                )
+          mbLeiosCertBytes =
+            Just (serialize version (encodeNullStrictMaybe encCBOR mbLeiosCert))
           mbPerasCertBytes =
-            fmap (serialize version) (strictMaybeToMaybe mbPerasCert)
+            Just (serialize version (encodeNullStrictMaybe encCBOR mbPerasCert))
        in DijkstraBlockBodyInternal
             { dbbTxs = txns
+            , dbbLeiosCert = mbLeiosCert
             , dbbPerasCert = mbPerasCert
             , dbbHash =
                 hashDijkstraSegWits
                   txSeqBodies
                   txSeqWits
                   txSeqAuxDatas
                   txSeqIsValids
+                  mbLeiosCertBytes
                   mbPerasCertBytes
             , dbbTxsBodyBytes = txSeqBodies
             , dbbTxsWitsBytes = txSeqWits
             , dbbTxsAuxDataBytes = txSeqAuxDatas
             , dbbTxsIsValidBytes = txSeqIsValids
+            , dbbLeiosCertBytes = mbLeiosCertBytes
             , dbbPerasCertBytes = mbPerasCertBytes
             }
 
@@ -185,6 +220,7 @@ deriving via
      , "dbbTxsWitsBytes"
      , "dbbTxsAuxDataBytes"
      , "dbbTxsIsValidBytes"
+     , "dbbLeiosCertBytes"
      , "dbbPerasCertBytes"
      ]
     (DijkstraBlockBody era)
@@ -207,8 +243,13 @@ instance Era era => EncCBORGroup (DijkstraBlockBody era) where
           <> dbbTxsWitsBytes blockBody
           <> dbbTxsAuxDataBytes blockBody
           <> dbbTxsIsValidBytes blockBody
+          <> fromMaybe BSL.empty (dbbLeiosCertBytes blockBody)
           <> fromMaybe BSL.empty (dbbPerasCertBytes blockBody)
-  listLen _ = 5
+
+  -- The cert byte fields always encode something (a CBOR null when
+  -- absent, the cert value when present), so the body always has 6
+  -- elements.
+  listLen _ = 6
 
 hashDijkstraSegWits ::
   BSL.ByteString ->
@@ -220,14 +261,17 @@ hashDijkstraSegWits ::
   BSL.ByteString ->
   -- | Bytes for transaction isValid flags
   Maybe BSL.ByteString ->
+  -- | Bytes for optional Leios certificate
+  Maybe BSL.ByteString ->
   -- | Bytes for optional Peras certificate
   Hash HASH EraIndependentBlockBody
-hashDijkstraSegWits txSeqBodies txSeqWits txAuxData txSeqIsValids mbPerasCert =
+hashDijkstraSegWits txSeqBodies txSeqWits txAuxData txSeqIsValids mbLeiosCert mbPerasCert =
   coerce . hashLazy . toLazyByteString $
     hashPart txSeqBodies
       <> hashPart txSeqWits
       <> hashPart txAuxData
       <> hashPart txSeqIsValids
+      <> maybe mempty hashPart mbLeiosCert
       <> maybe mempty hashPart mbPerasCert
   where
     hashLazy :: BSL.ByteString -> Hash HASH ByteString
@@ -246,9 +290,12 @@ instance
   ) =>
   DecCBOR (Annotator (DijkstraBlockBody era))
   where
+  -- The body is encoded as 6 group elements (via 'encCBORGroup'), so
+  -- the outer 'decodeRecordNamed \"Block\" (const 7)' in
+  -- 'Cardano.Ledger.Block' already consumed the list-length header.
+  -- We just sequence the 6 items here (no inner 'decodeListLen'),
+  -- matching the Alonzo/Conway-style body decoder.
   decCBOR = do
-    len <- decodeListLen
-
     (bodies, bodiesAnn) <- withSlice decCBOR
     (wits, witsAnn) <- withSlice decCBOR
     let bodiesLength = length bodies
@@ -279,27 +326,35 @@ instance
             StrictSeq.forceToStrict $
               Seq.zipWith4 dijkstraSegwitTx bodies wits validFlags auxData
 
-    (mbPerasCert, mbPerasCertAnn) <-
-      case len of
-        4 -> return (pure SNothing, pure Nothing)
-        5 -> bimap (pure . SJust) (fmap Just) <$> withSlice decCBOR
-        _ -> fail $ "unexpected body length: " <> show len
+    -- Each cert slot is always present as 'encodeNullStrictMaybe'
+    -- (CBOR null when absent, value when present).
+    (leios, leiosSliceAnn) <-
+      withSlice (decodeNullStrictMaybe (decCBOR @LeiosCert))
+    (peras, perasSliceAnn) <-
+      withSlice (decodeNullStrictMaybe (decCBOR @PerasCert))
+    let mbLeiosCert = pure leios
+        mbLeiosCertAnn = Just <$> leiosSliceAnn
+        mbPerasCert = pure peras
+        mbPerasCertAnn = Just <$> perasSliceAnn
 
     pure $
       DijkstraBlockBodyInternal
         <$> txns
+        <*> mbLeiosCert
         <*> mbPerasCert
         <*> ( hashDijkstraSegWits
                 <$> bodiesAnn
                 <*> witsAnn
                 <*> auxDataAnn
                 <*> isValAnn
+                <*> mbLeiosCertAnn
                 <*> mbPerasCertAnn
             )
         <*> bodiesAnn
         <*> witsAnn
         <*> auxDataAnn
         <*> isValAnn
+        <*> mbLeiosCertAnn
         <*> mbPerasCertAnn
 
 --------------------------------------------------------------------------------

eras/dijkstra/impl/test/Main.hs

@@ -13,6 +13,7 @@ import Test.Cardano.Ledger.Dijkstra.Binary.Annotator ()
 import qualified Test.Cardano.Ledger.Dijkstra.Binary.CddlSpec as Cddl
 import qualified Test.Cardano.Ledger.Dijkstra.Binary.Golden as Golden
 import Test.Cardano.Ledger.Dijkstra.Binary.RoundTrip ()
+import qualified Test.Cardano.Ledger.Dijkstra.BlockBodySpec as BlockBodySpec
 import qualified Test.Cardano.Ledger.Dijkstra.GoldenSpec as GoldenSpec
 import qualified Test.Cardano.Ledger.Dijkstra.Imp as Imp
 import Test.Cardano.Ledger.Dijkstra.ImpTest ()
@@ -26,6 +27,7 @@ main =
       describe "RoundTrip" $ do
         roundTripConwayCommonSpec @DijkstraEra
       Cddl.spec
+      BlockBodySpec.spec
       GoldenSpec.spec
       roundTripJsonShelleyEraSpec @DijkstraEra
       describe "Imp" $ do