[Peras] The big PR

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

@@ -16,6 +16,8 @@ module Ouroboros.Consensus.Shelley.Ledger.Block
   ( GetHeader (..)
   , Header (..)
   , IsShelleyBlock
+  , ShelleyPerasCertCompatibleWithLedger (..)
+  , LedgerPerasCertError
   , NestedCtxt_ (..)
   , ShelleyBasedEra
   , ShelleyBlock (..)
@@ -50,11 +52,12 @@ import Cardano.Ledger.Binary
 import qualified Cardano.Ledger.Binary.Plain as Plain
 import qualified Cardano.Ledger.Block as SL (EraBlockHeader)
 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)
@@ -138,6 +141,7 @@ class
     StateSupportsPerasEpochContext (ShelleyBlock proto era)
   , BlockSupportsPeras (ShelleyBlock proto era)
   , MaybeEraIndexedEpochToPerasRoundInfo (ShelleyBlock proto era) ~ EpochToPerasRoundInfo
+  , ShelleyPerasCertCompatibleWithLedger proto era
   ) =>
   ShelleyCompatible proto era
 
@@ -260,6 +264,32 @@ instance ShelleyCompatible proto era => HasAnnTip (ShelleyBlock proto era)
 -- "Ouroboros.Consensus.Shelley.Ledger.Ledger" module because of the
 -- dependency on the 'LedgerConfig'.
 
+{-------------------------------------------------------------------------------
+  Conversion between Peras certificates type between Ledger and Consensus
+-------------------------------------------------------------------------------}
+
+-- | Error type for Ledger <=> Consensus Peras certificate conversions.
+--
+-- NOTE: this will disappear once we have a proper type for Peras certificates
+-- in the Ledger.
+type LedgerPerasCertError = String
+
+-- | Bridge between the Peras certificates types between Consensus and Ledger
+--
+-- NOTE: this will disappear once we have a proper type for Peras certificates
+-- in the Ledger.
+class ShelleyPerasCertCompatibleWithLedger proto era where
+  -- | Extract a Peras certificate from a Shelley block body, if present
+  extractPerasCertFromShelleyBlockBody ::
+    BlockBody era ->
+    Either LedgerPerasCertError (Maybe (PerasCert (ShelleyBlock proto era)))
+
+  -- | Inject a Peras certificate into a Shelley block body
+  injectPerasCertIntoShelleyBlockBody ::
+    PerasCert (ShelleyBlock proto era) ->
+    BlockBody era ->
+    BlockBody era
+
 {-------------------------------------------------------------------------------
   Conversions
 -------------------------------------------------------------------------------}

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

@@ -72,6 +72,7 @@ forgeShelleyBlock
       SL.mkBasicBlockBody
         & SL.txSeqBlockBodyL
           .~ Seq.fromList (fmap extractTx fbTxs)
+        & maybe id injectPerasCertIntoShelleyBlockBody fbPerasCert
 
     actualBodySize = SL.blockBodySize protocolVersion body
 

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -11,14 +12,32 @@
 -- NOTE: this module exists solely because the orphan module
 -- 'Ouroboros.Consensus.Shelley.Node.Serialisation' needs some of these
 -- instances, but defining them there would be too confusing.
-module Ouroboros.Consensus.Shelley.Node.Peras () where
+module Ouroboros.Consensus.Shelley.Node.Peras
+  ( -- * Exported for testing purposes only
+    toOpaqueLedgerPerasCert
+  , fromOpaqueLedgerPerasCert
+  ) where
 
-import Cardano.Binary (serialize)
+import Cardano.Binary (Decoder, Encoding, FromCBOR (..), ToCBOR (..), serialize)
 import Cardano.Ledger.Api
+import qualified Cardano.Ledger.Binary as CBOR
+import qualified Cardano.Ledger.Dijkstra.BlockBody as SL
+import qualified Cardano.Ledger.Shelley.API as SL
+import qualified Codec.CBOR.Read as CBOR
 import Control.Monad (when)
+import Data.Array.Byte (ByteArray)
+import Data.Bifunctor (Bifunctor (..))
+import Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString.Lazy as LazyByteString
+import qualified Data.ByteString.Short as ShortByteString
+import Data.Maybe.Strict (StrictMaybe (..))
 import qualified Data.Measure as Measure
+import Data.MemPack.Buffer
+  ( byteArrayFromShortByteString
+  , byteArrayToShortByteString
+  )
 import Data.Typeable (Typeable)
+import Lens.Micro ((.~), (^.))
 import Ouroboros.Consensus.Block.SupportsPeras
   ( BlockSupportsPeras (..)
   , ValidatedPerasCert (..)
@@ -46,6 +65,9 @@ import Ouroboros.Consensus.Peras.Context
   , mkBoundedPerasEpochContextWith
   )
 import qualified Ouroboros.Consensus.Peras.Crypto.BLS as BLS
+import Ouroboros.Consensus.Peras.Crypto.BLS.Unsafe
+  ( unsafePerasBLSPrivateKeyFromEnv
+  )
 import qualified Ouroboros.Consensus.Peras.Error.V1 as V1
 import Ouroboros.Consensus.Peras.Params (dijkstraPerasMaxCertSize)
 import qualified Ouroboros.Consensus.Peras.Vote.V1 as V1
@@ -54,7 +76,11 @@ import Ouroboros.Consensus.Protocol.Abstract
   ( ChainDepStateSupportsPeras
   , ConsensusProtocol (..)
   )
-import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock (..))
+import Ouroboros.Consensus.Shelley.Ledger.Block
+  ( LedgerPerasCertError
+  , ShelleyBlock (..)
+  , ShelleyPerasCertCompatibleWithLedger (..)
+  )
 import Ouroboros.Consensus.Shelley.Ledger.Ledger ()
 import Ouroboros.Consensus.Shelley.Ledger.Mempool (AlonzoMeasure (..))
 import Ouroboros.Consensus.Ticked (Ticked)
@@ -315,4 +341,103 @@ instance
         V1.PerasCertTooLargeError sizeUpperBound dijkstraPerasMaxCertSize
     pure cert
   verifyPerasCert = defaultVerifyPerasCert
-  getPerasCertInBlock _ = Right Nothing
+  getPerasCertInBlock blk =
+    bimap V1.PerasTemporaryCertInBlockError id
+      . extractPerasCertFromShelleyBlockBody
+      . SL.blockBody
+      . shelleyBlockRaw
+      $ blk
+  readPerasPrivateKeyFromEnv _ =
+    unsafePerasBLSPrivateKeyFromEnv
+
+{-------------------------------------------------------------------------------
+  ShelleyPerasCertCompatibleWithLedger
+-------------------------------------------------------------------------------}
+
+-- NOTE: these instances will be removed once we have a proper type for Peras
+-- certificates in the ledger.
+
+instance ShelleyPerasCertCompatibleWithLedger proto ShelleyEra where
+  extractPerasCertFromShelleyBlockBody _ = Right Nothing
+  injectPerasCertIntoShelleyBlockBody _ = id
+
+instance ShelleyPerasCertCompatibleWithLedger proto AllegraEra where
+  extractPerasCertFromShelleyBlockBody _ = Right Nothing
+  injectPerasCertIntoShelleyBlockBody _ = id
+
+instance ShelleyPerasCertCompatibleWithLedger proto MaryEra where
+  extractPerasCertFromShelleyBlockBody _ = Right Nothing
+  injectPerasCertIntoShelleyBlockBody _ = id
+
+instance ShelleyPerasCertCompatibleWithLedger proto AlonzoEra where
+  extractPerasCertFromShelleyBlockBody _ = Right Nothing
+  injectPerasCertIntoShelleyBlockBody _ = id
+
+instance ShelleyPerasCertCompatibleWithLedger proto BabbageEra where
+  extractPerasCertFromShelleyBlockBody _ = Right Nothing
+  injectPerasCertIntoShelleyBlockBody _ = id
+
+instance ShelleyPerasCertCompatibleWithLedger proto ConwayEra where
+  extractPerasCertFromShelleyBlockBody _ = Right Nothing
+  injectPerasCertIntoShelleyBlockBody _ = id
+
+instance
+  Typeable proto =>
+  ShelleyPerasCertCompatibleWithLedger proto DijkstraEra
+  where
+  extractPerasCertFromShelleyBlockBody blockBody =
+    case blockBody ^. SL.perasCertBlockBodyL of
+      SNothing ->
+        Right Nothing
+      SJust ledgerCert ->
+        case fromOpaqueLedgerPerasCert ledgerCert of
+          Left err -> Left err
+          Right cert -> Right (Just cert)
+
+  injectPerasCertIntoShelleyBlockBody cert =
+    SL.perasCertBlockBodyL .~ SJust (toOpaqueLedgerPerasCert cert)
+
+toOpaqueLedgerPerasCert ::
+  Typeable blk =>
+  V1.PerasCert blk ->
+  SL.PerasCert
+toOpaqueLedgerPerasCert =
+  SL.PerasCert . toByteArray . toCBOR
+ where
+  toByteArray :: Encoding -> ByteArray
+  toByteArray =
+    byteArrayFromShortByteString
+      . ShortByteString.toShort
+      . CBOR.toStrictByteString
+
+fromOpaqueLedgerPerasCert ::
+  Typeable blk =>
+  SL.PerasCert ->
+  Either LedgerPerasCertError (V1.PerasCert blk)
+fromOpaqueLedgerPerasCert (SL.PerasCert byteArray) =
+  fromByteArray fromCBOR byteArray
+ where
+  fromByteArray ::
+    (forall s. Decoder s (V1.PerasCert blk)) ->
+    ByteArray ->
+    Either LedgerPerasCertError (V1.PerasCert blk)
+  fromByteArray decoder =
+    handleParseErrors
+      . CBOR.deserialiseFromBytes decoder
+      . LazyByteString.fromStrict
+      . ShortByteString.fromShort
+      . byteArrayToShortByteString
+
+  handleParseErrors ::
+    Either CBOR.DeserialiseFailure (ByteString, a) ->
+    Either LedgerPerasCertError a
+  handleParseErrors = \case
+    Left err -> failure err
+    Right (trailing, a)
+      | not (LazyByteString.null trailing) -> failure "trailing bytes"
+      | otherwise -> pure a
+   where
+    failure err =
+      Left $
+        "Failed to deserialize opaque Peras certificate from byte array: "
+          <> show err

ouroboros-consensus-cardano/test/shelley-test/Main.hs

@@ -4,6 +4,7 @@ import qualified Test.Consensus.Shelley.Coherence (tests)
 import qualified Test.Consensus.Shelley.EndorserBlock (tests)
 import qualified Test.Consensus.Shelley.Golden (tests)
 import qualified Test.Consensus.Shelley.LedgerTables (tests)
+import qualified Test.Consensus.Shelley.Peras (tests)
 import qualified Test.Consensus.Shelley.Serialisation (tests)
 import qualified Test.Consensus.Shelley.SupportedNetworkProtocolVersion (tests)
 import Test.Tasty
@@ -24,6 +25,7 @@ tests =
     , Test.Consensus.Shelley.EndorserBlock.tests
     , Test.Consensus.Shelley.Golden.tests
     , Test.Consensus.Shelley.LedgerTables.tests
+    , Test.Consensus.Shelley.Peras.tests
     , Test.Consensus.Shelley.Serialisation.tests
     , Test.Consensus.Shelley.SupportedNetworkProtocolVersion.tests
     , Test.ThreadNet.Shelley.tests

ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Peras.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Test.Consensus.Shelley.Peras (tests) where
+
+import Cardano.Binary (ToCBOR (..))
+import qualified Cardano.Ledger.Dijkstra.BlockBody as SL
+import qualified Codec.CBOR.Write as CBOR
+import qualified Data.ByteString.Short as Short
+import Data.MemPack.Buffer (byteArrayFromShortByteString)
+import Ouroboros.Consensus.Block (Point (..))
+import Ouroboros.Consensus.Block.SupportsPeras (PerasCert)
+import Ouroboros.Consensus.Peras.Cert.Mock (MockPerasCert (..))
+import Ouroboros.Consensus.Shelley.HFEras (StandardDijkstraBlock)
+import Ouroboros.Consensus.Shelley.Node.Peras
+  ( fromOpaqueLedgerPerasCert
+  , toOpaqueLedgerPerasCert
+  )
+import Test.Ouroboros.Storage.TestBlock (TestBlock)
+import Test.QuickCheck
+  ( Gen
+  , Property
+  , counterexample
+  , forAll
+  , property
+  , (===)
+  )
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.QuickCheck (testProperty)
+import Test.Util.Peras (genPerasCert)
+import Test.Util.Peras.Common (genRoundNo)
+import Test.Util.Peras.Mock (genMockPerasVoterIndices)
+
+tests :: TestTree
+tests =
+  testGroup
+    "ShelleyBlockPerasCert"
+    [ testProperty
+        "Roundtrip through ShelleyBlockPerasCert for Dijkstra"
+        prop_DijkstraPerasCertRoundtrip
+    , testProperty
+        "Deserializing an invalid Dijkstra Peras certificate fails"
+        prop_DijkstraPerasCertRoundtripError
+    ]
+
+prop_DijkstraPerasCertRoundtrip :: Property
+prop_DijkstraPerasCertRoundtrip =
+  forAll (genPerasCert @StandardDijkstraBlock True) $ \cert -> do
+    let ledgerCert = toOpaqueLedgerPerasCert cert
+    counterexample ("Ledger cert: " <> show ledgerCert) $
+      fromOpaqueLedgerPerasCert ledgerCert === Right cert
+
+prop_DijkstraPerasCertRoundtripError :: Property
+prop_DijkstraPerasCertRoundtripError =
+  forAll genInvalidLedgerPerasCert $ \ledgerCert ->
+    case fromOpaqueLedgerPerasCert ledgerCert of
+      Left _ ->
+        property True
+      Right (cert :: PerasCert StandardDijkstraBlock) ->
+        counterexample
+          ("Didn't fail to decode an invalid Dijkstra cert from: " <> show cert)
+          $ False
+
+-- | Generate an invalid ledger Peras cert by serializing a random mocked one.
+genInvalidLedgerPerasCert :: Gen SL.PerasCert
+genInvalidLedgerPerasCert = do
+  mockCertRound <- genRoundNo
+  mockCertVoters <- genMockPerasVoterIndices
+  let mockCertBlock = GenesisPoint @TestBlock
+  pure
+    . SL.PerasCert
+    . byteArrayFromShortByteString
+    . Short.toShort
+    . CBOR.toStrictByteString
+    . toCBOR
+    $ MockPerasCert
+      { mockCertRound
+      , mockCertBlock
+      , mockCertVoters
+      }