Merge #2754

2754: Add a pure Mary mode r=mrBliss a=mrBliss Note that this mode is not tested by consensus like the others, i.e., we only test the Mary era as part of the Cardano blockchain, not on its own. Co-authored-by: Thomas Winant <thomas@well-typed.com>
IntersectMBO · Nov 24, 2020 · 57ab004 · 57ab004
2 parents 44b61df + 5ecfafa
commit 57ab004
Show file tree

Hide file tree

Showing 2 changed files with 26 additions and 2 deletions.
diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs
@@ -70,6 +70,7 @@ import           Ouroboros.Consensus.Cardano.ShelleyHFC
 
 type ProtocolByron   = HardForkProtocol '[ ByronBlock ]
 type ProtocolShelley = HardForkProtocol '[ ShelleyBlock StandardShelley ]
+type ProtocolMary    = HardForkProtocol '[ ShelleyBlock StandardMary ]
 type ProtocolCardano = HardForkProtocol '[ ByronBlock
                                          , ShelleyBlock StandardShelley
                                          , ShelleyBlock StandardAllegra
@@ -82,17 +83,23 @@ type ProtocolCardano = HardForkProtocol '[ ByronBlock
 
 -- | Consensus protocol to use
 data Protocol (m :: Type -> Type) blk p where
-  -- | Run PBFT against the real Byron ledger
+  -- | Run PBFT against the Byron ledger
   ProtocolByron
     :: ProtocolParamsByron
     -> Protocol m ByronBlockHFC ProtocolByron
 
-  -- | Run TPraos against the real Shelley ledger
+  -- | Run TPraos against the Shelley ledger
   ProtocolShelley
     :: ProtocolParamsShelleyBased StandardShelley []
     -> ProtocolParamsShelley
     -> Protocol m (ShelleyBlockHFC StandardShelley) ProtocolShelley
 
+  -- | Run TPraos against the Mary ledger
+  ProtocolMary
+    :: ProtocolParamsShelleyBased StandardMary []
+    -> ProtocolParamsMary
+    -> Protocol m (ShelleyBlockHFC StandardMary) ProtocolMary
+
   -- | Run the protocols of /the/ Cardano block
   ProtocolCardano
     :: ProtocolParamsByron
@@ -114,6 +121,7 @@ data Protocol (m :: Type -> Type) blk p where
 verifyProtocol :: Protocol m blk p -> (p :~: BlockProtocol blk)
 verifyProtocol ProtocolByron{}   = Refl
 verifyProtocol ProtocolShelley{} = Refl
+verifyProtocol ProtocolMary{}    = Refl
 verifyProtocol ProtocolCardano{} = Refl
 
 {-------------------------------------------------------------------------------
@@ -129,6 +137,9 @@ protocolInfo (ProtocolByron params) =
 protocolInfo (ProtocolShelley paramsShelleyBased paramsShelley) =
     inject $ protocolInfoShelley paramsShelleyBased paramsShelley
 
+protocolInfo (ProtocolMary paramsShelleyBased paramsMary) =
+    inject $ protocolInfoMary paramsShelleyBased paramsMary
+
 protocolInfo (ProtocolCardano
                paramsByron
                paramsShelleyBased
@@ -155,6 +166,7 @@ protocolInfo (ProtocolCardano
 runProtocol :: Protocol m blk p -> Dict (RunNode blk)
 runProtocol ProtocolByron{}   = Dict
 runProtocol ProtocolShelley{} = Dict
+runProtocol ProtocolMary{}    = Dict
 runProtocol ProtocolCardano{} = Dict
 
 {-------------------------------------------------------------------------------

diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs
@@ -20,6 +20,7 @@
 module Ouroboros.Consensus.Shelley.Node (
     protocolInfoShelleyBased
   , protocolInfoShelley
+  , protocolInfoMary
   , ProtocolParamsShelleyBased (..)
   , ProtocolParamsShelley (..)
   , ProtocolParamsAllegra (..)
@@ -248,6 +249,17 @@ protocolInfoShelley protocolParamsShelleyBased
                       } =
     protocolInfoShelleyBased protocolParamsShelleyBased protVer
 
+protocolInfoMary ::
+     forall m c f. (IOLike m, ShelleyBasedEra (MaryEra c), Foldable f)
+  => ProtocolParamsShelleyBased (MaryEra c) f
+  -> ProtocolParamsMary
+  -> ProtocolInfo m (ShelleyBlock (MaryEra c))
+protocolInfoMary protocolParamsShelleyBased
+                 ProtocolParamsMary {
+                     maryProtVer = protVer
+                   } =
+    protocolInfoShelleyBased protocolParamsShelleyBased protVer
+
 protocolInfoShelleyBased ::
      forall m era f. (IOLike m, ShelleyBasedEra era, Foldable f)
   => ProtocolParamsShelleyBased era f