WIP add peras cert to ShelleyBlock and adapt serialization test suite

Author: agustinmista

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 #-}
@@ -29,6 +30,7 @@ module Ouroboros.Consensus.Shelley.Ledger.Block
   , fromShelleyBlock
   , toShelleyBlock
   , mkShelleyBlock
+  , mkShelleyBlockWithPerasCert
   , mkShelleyHeader
 
     -- * Serialisation
@@ -48,7 +50,12 @@ import Cardano.Ledger.Binary
   ( Annotator (..)
   , DecCBOR (..)
   , EncCBOR (..)
+  , EncCBORGroup (..)
   , FullByteString (..)
+  , cborError
+  , decodeListLen
+  , encodeListLen
+  , fromPlainDecoder
   , serialize
   )
 import qualified Cardano.Ledger.Binary.Plain as Plain
@@ -63,9 +70,11 @@ 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 (..))
@@ -151,6 +160,7 @@ instance ShelleyCompatible proto era => ConvertRawHash (ShelleyBlock proto era)
 data ShelleyBlock proto era = ShelleyBlock
   { shelleyBlockHeader :: !(ShelleyProtocolHeader proto)
   , shelleyBlockBody :: !(SL.BlockBody era)
+  , shelleyBlockPerasCert :: !(StrictMaybe (PerasCert (ShelleyBlock proto era)))
   , shelleyBlockHeaderHash :: !ShelleyHash
   }
 
@@ -181,10 +191,27 @@ mkShelleyBlock ::
   ShelleyProtocolHeader proto ->
   SL.BlockBody era ->
   ShelleyBlock proto era
-mkShelleyBlock header body =
+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
     { shelleyBlockHeader = header
     , shelleyBlockBody = body
+    , shelleyBlockPerasCert = cert
     , shelleyBlockHeaderHash = pHeaderHash header
     }
 
@@ -308,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 . fromShelleyBlock
+  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 toShelleyBlock <$> 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
@@ -362,7 +414,7 @@ decodeShelleyHeader = eraDecoder @era $ (. Full) . runAnnotator <$> decCBOR
 -------------------------------------------------------------------------------}
 
 instance ShelleyCompatible proto era => Condense (ShelleyBlock proto era) where
-  condense = show . (shelleyBlockHeader &&& shelleyBlockBody)
+  condense = show . ((shelleyBlockHeader &&& shelleyBlockBody) &&& shelleyBlockPerasCert)
 
 instance ShelleyCompatible proto era => Condense (Header (ShelleyBlock proto era)) where
   condense = show . shelleyHeaderRaw

ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs

@@ -55,6 +55,7 @@ import Ouroboros.Consensus.Protocol.TPraos
   ( TPraos
   , TPraosState (TPraosState)
   )
+import Ouroboros.Consensus.Shelley.Eras (isBeforeDijkstra)
 import Ouroboros.Consensus.Shelley.HFEras
 import Ouroboros.Consensus.Shelley.Ledger
 import Ouroboros.Consensus.Shelley.Ledger.Query.Types
@@ -79,8 +80,9 @@ import Test.Cardano.Protocol.TPraos.Examples
 import Test.Util.Orphans.Arbitrary ()
 import Test.Util.Serialisation.Examples
   ( Examples (..)
+  , addLabelSuffix
   , labelled
-  , unlabelled
+  , maybeLabelled
   )
 import Test.Util.Serialisation.SomeResult (SomeResult (..))
 
@@ -120,35 +122,46 @@ mkLedgerTables tx =
     xs -> xs
 
 fromShelleyLedgerExamples ::
+  forall era.
   ShelleyCompatible (TPraos StandardCrypto) era =>
   ProtocolLedgerExamples (SL.BHeader StandardCrypto) era ->
   Examples (ShelleyBlock (TPraos StandardCrypto) era)
 fromShelleyLedgerExamples
   ProtocolLedgerExamples
     { pleLedgerExamples = Shelley.LedgerExamples{..}
     , ..
-    } =
-    Examples
-      { exampleBlock = unlabelled blk
-      , exampleSerialisedBlock = unlabelled serialisedBlock
-      , exampleHeader = unlabelled $ getHeader blk
-      , exampleSerialisedHeader = unlabelled serialisedHeader
-      , exampleHeaderHash = unlabelled hash
-      , exampleGenTx = unlabelled tx
-      , exampleGenTxId = unlabelled $ txId tx
-      , exampleApplyTxErr = unlabelled leApplyTxError
-      , exampleQuery = queries
-      , exampleResult = results
-      , exampleAnnTip = unlabelled annTip
-      , exampleLedgerState = unlabelled ledgerState
-      , exampleChainDepState = unlabelled chainDepState
-      , exampleExtLedgerState = unlabelled extLedgerState
-      , exampleSlotNo = unlabelled slotNo
-      , exampleLedgerConfig = unlabelled ledgerConfig
-      , exampleLedgerTables = unlabelled $ mkLedgerTables leTx
-      }
+    }
+    | isBeforeDijkstra (Proxy @era) =
+        mkExample Nothing blkWithoutCert
+    | otherwise =
+        mkExample (Just "WithoutPerasCert") blkWithoutCert
+          <> mkExample (Just "WithPerasCert") blkWithCert
    where
-    blk = toShelleyBlock pleBlock
+    mkExample lbl blk =
+      Examples
+        { exampleBlock = maybeLabelled lbl blk
+        , exampleSerialisedBlock = maybeLabelled lbl serialisedBlock
+        , exampleHeader = maybeLabelled lbl (getHeader blk)
+        , exampleSerialisedHeader = maybeLabelled lbl serialisedHeader
+        , exampleHeaderHash = maybeLabelled lbl hash
+        , exampleGenTx = maybeLabelled lbl tx
+        , exampleGenTxId = maybeLabelled lbl (txId tx)
+        , exampleApplyTxErr = maybeLabelled lbl leApplyTxError
+        , exampleQuery = maybe queries (flip addLabelSuffix queries) lbl
+        , exampleResult = maybe results (flip addLabelSuffix results) lbl
+        , exampleAnnTip = maybeLabelled lbl annTip
+        , exampleLedgerState = maybeLabelled lbl ledgerState
+        , exampleChainDepState = maybeLabelled lbl chainDepState
+        , exampleExtLedgerState = maybeLabelled lbl extLedgerState
+        , exampleSlotNo = maybeLabelled lbl slotNo
+        , exampleLedgerConfig = maybeLabelled lbl ledgerConfig
+        , exampleLedgerTables = maybeLabelled lbl (mkLedgerTables leTx)
+        }
+
+    SL.Block header body = pleBlock
+    blkWithoutCert = mkShelleyBlock header body
+    blkWithCert = mkShelleyBlockWithPerasCert perasCert header body
+
     hash = ShelleyHash $ SL.unHashHeader pleHashHeader
     serialisedBlock = Serialised "<BLOCK>"
     tx = mkShelleyTx leTx
@@ -169,7 +182,7 @@ fromShelleyLedgerExamples
         ]
     results =
       labelled
-        [ ("LedgerTip", SomeResult GetLedgerTip (blockPoint blk))
+        [ ("LedgerTip", SomeResult GetLedgerTip (blockPoint blkWithoutCert))
         , ("EpochNo", SomeResult GetEpochNo (EpochNo 10))
         , ("EmptyPParams", SomeResult GetCurrentPParams lePParams)
         , ("StakeDistribution", SomeResult GetStakeDistribution $ fromLedgerPoolDistr lePoolDistr)
@@ -228,6 +241,11 @@ fromShelleyLedgerExamples
       ExtLedgerState
         ledgerState
         (genesisHeaderState chainDepState)
+    perasCert =
+      PerasCert
+        { pcCertRound = PerasRoundNo 10
+        , pcCertBoostedBlock = blockPoint blkWithoutCert
+        }
 
     ledgerConfig = exampleShelleyLedgerConfig leTranslationContext
 
@@ -241,31 +259,39 @@ fromShelleyLedgerExamplesPraos
   ProtocolLedgerExamples
     { pleLedgerExamples = Shelley.LedgerExamples{..}
     , ..
-    } =
-    Examples
-      { exampleBlock = unlabelled blk
-      , exampleSerialisedBlock = unlabelled serialisedBlock
-      , exampleHeader = unlabelled $ getHeader blk
-      , exampleSerialisedHeader = unlabelled serialisedHeader
-      , exampleHeaderHash = unlabelled hash
-      , exampleGenTx = unlabelled tx
-      , exampleGenTxId = unlabelled $ txId tx
-      , exampleApplyTxErr = unlabelled leApplyTxError
-      , exampleQuery = queries
-      , exampleResult = results
-      , exampleAnnTip = unlabelled annTip
-      , exampleLedgerState = unlabelled ledgerState
-      , exampleLedgerTables = unlabelled $ mkLedgerTables leTx
-      , exampleChainDepState = unlabelled chainDepState
-      , exampleExtLedgerState = unlabelled extLedgerState
-      , exampleSlotNo = unlabelled slotNo
-      , exampleLedgerConfig = unlabelled ledgerConfig
-      }
+    }
+    | isBeforeDijkstra (Proxy @era) =
+        mkExample Nothing blkWithoutCert
+    | otherwise =
+        mkExample (Just "WithoutPerasCert") blkWithoutCert
+          <> mkExample (Just "WithPerasCert") blkWithCert
    where
-    blk =
-      toShelleyBlock $
-        let SL.Block hdr1 bdy = pleBlock
-         in SL.Block (translateHeader hdr1) bdy
+    mkExample lbl blk =
+      Examples
+        { exampleBlock = maybeLabelled lbl blk
+        , exampleSerialisedBlock = maybeLabelled lbl serialisedBlock
+        , exampleHeader = maybeLabelled lbl $ getHeader blk
+        , exampleSerialisedHeader = maybeLabelled lbl serialisedHeader
+        , exampleHeaderHash = maybeLabelled lbl hash
+        , exampleGenTx = maybeLabelled lbl tx
+        , exampleGenTxId = maybeLabelled lbl $ txId tx
+        , exampleApplyTxErr = maybeLabelled lbl leApplyTxError
+        , exampleQuery = maybe queries (flip addLabelSuffix queries) lbl
+        , exampleResult = maybe results (flip addLabelSuffix results) lbl
+        , exampleAnnTip = maybeLabelled lbl annTip
+        , exampleLedgerState = maybeLabelled lbl ledgerState
+        , exampleLedgerTables = maybeLabelled lbl $ mkLedgerTables leTx
+        , exampleChainDepState = maybeLabelled lbl chainDepState
+        , exampleExtLedgerState = maybeLabelled lbl extLedgerState
+        , exampleSlotNo = maybeLabelled lbl slotNo
+        , exampleLedgerConfig = maybeLabelled lbl ledgerConfig
+        }
+
+    SL.Block header' body = pleBlock
+    header = translateHeader header'
+
+    blkWithoutCert = mkShelleyBlock header body
+    blkWithCert = mkShelleyBlockWithPerasCert perasCert header body
 
     translateHeader :: SL.BHeader StandardCrypto -> Praos.Header StandardCrypto
     translateHeader (SL.BHeader bhBody bhSig) =
@@ -305,7 +331,7 @@ fromShelleyLedgerExamplesPraos
         ]
     results =
       labelled
-        [ ("LedgerTip", SomeResult GetLedgerTip (blockPoint blk))
+        [ ("LedgerTip", SomeResult GetLedgerTip (blockPoint blkWithoutCert))
         , ("EpochNo", SomeResult GetEpochNo (EpochNo 10))
         , ("EmptyPParams", SomeResult GetCurrentPParams lePParams)
         , ("StakeDistribution", SomeResult GetStakeDistribution $ fromLedgerPoolDistr lePoolDistr)
@@ -366,6 +392,11 @@ fromShelleyLedgerExamplesPraos
       ExtLedgerState
         ledgerState
         (genesisHeaderState chainDepState)
+    perasCert =
+      PerasCert
+        { pcCertRound = PerasRoundNo 10
+        , pcCertBoostedBlock = blockPoint blkWithoutCert
+        }
 
     ledgerConfig = exampleShelleyLedgerConfig leTranslationContext
 

ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Examples.hs

@@ -14,6 +14,10 @@ module Test.Util.Serialisation.Examples
   , Labelled
   , labelled
   , unlabelled
+  , maybeLabelled
+  , mapLabel
+  , addLabelPrefix
+  , addLabelSuffix
   ) where
 
 import Data.Bifunctor (first)
@@ -138,16 +142,7 @@ mapExamples f = combineExamples (const f) mempty
 -- When a label is empty, the prefix is used as the label. If the label is not
 -- empty, the prefix and @_@ are prepended.
 prefixExamples :: String -> Examples blk -> Examples blk
-prefixExamples prefix = mapExamples addPrefix
- where
-  addPrefix :: Labelled a -> Labelled a
-  addPrefix l =
-    [ (Just label, x)
-    | (mbLabel, x) <- l
-    , let label = case mbLabel of
-            Nothing -> prefix
-            Just lbl -> prefix <> "_" <> lbl
-    ]
+prefixExamples prefix = mapExamples (addLabelPrefix prefix)
 
 {-------------------------------------------------------------------------------
   Labelling
@@ -160,3 +155,16 @@ unlabelled x = [(Nothing, x)]
 
 labelled :: [(String, a)] -> Labelled a
 labelled = map (first Just)
+
+maybeLabelled :: Maybe String -> a -> Labelled a
+maybeLabelled Nothing a = unlabelled a
+maybeLabelled (Just l) a = labelled [(l, a)]
+
+mapLabel :: String -> (String -> String) -> Labelled a -> Labelled a
+mapLabel def f xs = labelled [(maybe def f l, x) | (l, x) <- xs]
+
+addLabelPrefix :: String -> Labelled a -> Labelled a
+addLabelPrefix prefix = mapLabel prefix ((prefix <> "_") <>)
+
+addLabelSuffix :: String -> Labelled a -> Labelled a
+addLabelSuffix suffix = mapLabel suffix (<> ("_" <> suffix))