Refactor to make consensus modes open, move shelley code out of ourob…

…oros-consensus-cardano
IntersectMBO · Mar 16, 2021 · d0665e1 · d0665e1
1 parent 0326f5e
commit d0665e1
Show file tree

Hide file tree

Showing 14 changed files with 511 additions and 481 deletions.
diff --git a/ouroboros-consensus-cardano-test/test/Test/Consensus/Cardano/Serialisation.hs b/ouroboros-consensus-cardano-test/test/Test/Consensus/Cardano/Serialisation.hs
@@ -15,8 +15,6 @@ import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.Util (Dict (..))
 
-import           Ouroboros.Consensus.HardFork.Combinator (NestedCtxt_ (..))
-
 import           Ouroboros.Consensus.Byron.Ledger
 import           Ouroboros.Consensus.Byron.Node ()
 

diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal
@@ -28,7 +28,6 @@ library
                        Ouroboros.Consensus.Cardano
                        Ouroboros.Consensus.Cardano.Block
                        Ouroboros.Consensus.Cardano.ByronHFC
-                       Ouroboros.Consensus.Cardano.ShelleyHFC
                        Ouroboros.Consensus.Cardano.Condense
                        Ouroboros.Consensus.Cardano.CanHardFork
                        Ouroboros.Consensus.Cardano.Node

diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs
@@ -1,8 +1,13 @@
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE KindSignatures      #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
+{-# OPTIONS_GHC -Wno-orphans       #-}
 
 module Ouroboros.Consensus.Cardano (
     -- * The block type of the Cardano block chain
@@ -18,31 +23,16 @@ module Ouroboros.Consensus.Cardano (
   , ProtocolParamsMary(..)
   , ProtocolParamsTransition(..)
   , Protocol(..)
-  , verifyProtocol
-    -- * Data required to run a protocol
-  , protocolInfo
-    -- * Evidence that we can run all the supported protocols
-  , runProtocol
   , module X
-
     -- * Client support for nodes running a protocol
   , ProtocolClient(..)
-  , protocolClientInfo
-  , runProtocolClient
-  , verifyProtocolClient
+  , RunProtocol(..)
+  , RunProtocolClient(..)
   ) where
 
-import           Data.Kind (Type)
-import           Data.Type.Equality
-
 import           Cardano.Chain.Slotting (EpochSlots)
 
-import           Ouroboros.Consensus.Block
-import           Ouroboros.Consensus.Node.ProtocolInfo
-import           Ouroboros.Consensus.Node.Run
-import           Ouroboros.Consensus.Protocol.Abstract as X
-import           Ouroboros.Consensus.Protocol.PBFT as X
-import           Ouroboros.Consensus.Util
+import           Ouroboros.Consensus.Protocol as X
 import           Ouroboros.Consensus.Util.IOLike
 
 import           Ouroboros.Consensus.HardFork.Combinator
@@ -57,7 +47,7 @@ import           Ouroboros.Consensus.Shelley.Node as X
 import           Ouroboros.Consensus.Cardano.Block
 import           Ouroboros.Consensus.Cardano.ByronHFC
 import           Ouroboros.Consensus.Cardano.Node
-import           Ouroboros.Consensus.Cardano.ShelleyHFC
+import           Ouroboros.Consensus.Shelley.ShelleyHFC
 
 {-------------------------------------------------------------------------------
   Supported protocols
@@ -69,70 +59,28 @@ import           Ouroboros.Consensus.Cardano.ShelleyHFC
 -------------------------------------------------------------------------------}
 
 type ProtocolByron   = HardForkProtocol '[ ByronBlock ]
-type ProtocolShelley = HardForkProtocol '[ ShelleyBlock StandardShelley ]
 type ProtocolCardano = HardForkProtocol '[ ByronBlock
                                          , ShelleyBlock StandardShelley
                                          , ShelleyBlock StandardAllegra
                                          , ShelleyBlock StandardMary
                                          ]
 
-{-------------------------------------------------------------------------------
-  Abstract over the various protocols
--------------------------------------------------------------------------------}
-
--- | Consensus protocol to use
-data Protocol (m :: Type -> Type) blk p where
-  -- | Run PBFT against the Byron ledger
-  ProtocolByron
-    :: ProtocolParamsByron
-    -> Protocol m ByronBlockHFC ProtocolByron
-
-  -- | Run TPraos against the Shelley ledger
-  ProtocolShelley
-    :: ProtocolParamsShelleyBased StandardShelley
-    -> ProtocolParamsShelley
-    -> Protocol m (ShelleyBlockHFC StandardShelley) ProtocolShelley
-
-  -- | Run the protocols of /the/ Cardano block
-  --
-  -- WARNING: only a single set of Shelley credentials is allowed when used for
-  -- mainnet. Testnets allow multiple Shelley credentials.
-  ProtocolCardano
-    :: ProtocolParamsByron
-    -> ProtocolParamsShelleyBased StandardShelley
-    -> ProtocolParamsShelley
-    -> ProtocolParamsAllegra
-    -> ProtocolParamsMary
-    -> ProtocolParamsTransition
-         ByronBlock
-         (ShelleyBlock StandardShelley)
-    -> ProtocolParamsTransition
-         (ShelleyBlock StandardShelley)
-         (ShelleyBlock StandardAllegra)
-    -> ProtocolParamsTransition
-         (ShelleyBlock StandardAllegra)
-         (ShelleyBlock StandardMary)
-    -> Protocol m (CardanoBlock StandardCrypto) ProtocolCardano
-
-verifyProtocol :: Protocol m blk p -> (p :~: BlockProtocol blk)
-verifyProtocol ProtocolByron{}   = Refl
-verifyProtocol ProtocolShelley{} = Refl
-verifyProtocol ProtocolCardano{} = Refl
-
-{-------------------------------------------------------------------------------
-  Data required to run a protocol
--------------------------------------------------------------------------------}
-
--- | Data required to run the selected protocol
-protocolInfo :: forall m blk p. IOLike m
-             => Protocol m blk p -> ProtocolInfo m blk
-protocolInfo (ProtocolByron params) =
-    inject $ protocolInfoByron params
-
-protocolInfo (ProtocolShelley paramsShelleyBased paramsShelley) =
-    inject $ protocolInfoShelley paramsShelleyBased paramsShelley
-
-protocolInfo (ProtocolCardano
+-- | Run PBFT against the Byron ledger
+instance IOLike m => Protocol m ByronBlockHFC ProtocolByron where
+  data RunProtocol m ByronBlockHFC ProtocolByron = RunProtocolByron ProtocolParamsByron
+  protocolInfo (RunProtocolByron params) = inject $ protocolInfoByron params
+
+instance IOLike m => Protocol m (CardanoBlock StandardCrypto) ProtocolCardano where
+  data RunProtocol m (CardanoBlock StandardCrypto) ProtocolCardano = RunProtocolCardano
+    ProtocolParamsByron
+    (ProtocolParamsShelleyBased StandardShelley)
+    ProtocolParamsShelley
+    ProtocolParamsAllegra
+    ProtocolParamsMary
+    (ProtocolParamsTransition ByronBlock (ShelleyBlock StandardShelley))
+    (ProtocolParamsTransition (ShelleyBlock StandardShelley) (ShelleyBlock StandardAllegra))
+    (ProtocolParamsTransition (ShelleyBlock StandardAllegra) (ShelleyBlock StandardMary))
+  protocolInfo (RunProtocolCardano
                paramsByron
                paramsShelleyBased
                paramsShelley
@@ -151,61 +99,14 @@ protocolInfo (ProtocolCardano
       paramsShelleyAllegra
       paramsAllegraMary
 
-{-------------------------------------------------------------------------------
-  Evidence that we can run all the supported protocols
--------------------------------------------------------------------------------}
-
-runProtocol :: Protocol m blk p -> Dict (RunNode blk)
-runProtocol ProtocolByron{}   = Dict
-runProtocol ProtocolShelley{} = Dict
-runProtocol ProtocolCardano{} = Dict
-
-{-------------------------------------------------------------------------------
-  Client support for the protocols: what you need as a client of the node
--------------------------------------------------------------------------------}
-
--- | Node client support for each consensus protocol.
---
--- This is like 'Protocol' but for clients of the node, so with less onerous
--- requirements than to run a node.
---
-data ProtocolClient blk p where
-  ProtocolClientByron
-    :: EpochSlots
-    -> ProtocolClient
-         ByronBlockHFC
-         ProtocolByron
-
-  ProtocolClientShelley
-    :: ProtocolClient
-         (ShelleyBlockHFC StandardShelley)
-         ProtocolShelley
-
-  ProtocolClientCardano
-    :: EpochSlots
-    -> ProtocolClient
-         (CardanoBlock StandardCrypto)
-         ProtocolCardano
-
--- | Sanity check that we have the right type combinations
-verifyProtocolClient :: ProtocolClient blk p -> (p :~: BlockProtocol blk)
-verifyProtocolClient ProtocolClientByron{}   = Refl
-verifyProtocolClient ProtocolClientShelley{} = Refl
-verifyProtocolClient ProtocolClientCardano{} = Refl
-
--- | Sanity check that we have the right class instances available
-runProtocolClient :: ProtocolClient blk p -> Dict (RunNode blk)
-runProtocolClient ProtocolClientByron{}   = Dict
-runProtocolClient ProtocolClientShelley{} = Dict
-runProtocolClient ProtocolClientCardano{} = Dict
-
--- | Data required by clients of a node running the specified protocol.
-protocolClientInfo :: ProtocolClient blk p -> ProtocolClientInfo blk
-protocolClientInfo (ProtocolClientByron epochSlots) =
+instance ProtocolClient ByronBlockHFC ProtocolByron where
+  data RunProtocolClient ByronBlockHFC ProtocolByron =
+    RunProtocolClientByron EpochSlots
+  protocolClientInfo (RunProtocolClientByron epochSlots) =
     inject $ protocolClientInfoByron epochSlots
 
-protocolClientInfo ProtocolClientShelley =
-    inject $ protocolClientInfoShelley
-
-protocolClientInfo (ProtocolClientCardano epochSlots) =
+instance ProtocolClient (CardanoBlock StandardCrypto) ProtocolCardano where
+  data RunProtocolClient (CardanoBlock StandardCrypto) ProtocolCardano =
+    RunProtocolClientCardano EpochSlots
+  protocolClientInfo (RunProtocolClientCardano epochSlots) =
     protocolClientInfoCardano epochSlots