Merge #1475

1475: Update to use HFC for all protocol modes r=dcoutts a=dcoutts

We decided that it is simpler to have things be more uniform and use the
HFC for all protocol modes, and so in particular for the Byron-only and
Shelley-only modes.

Co-authored-by: Duncan Coutts <duncan@well-typed.com>

cabal.project

@@ -326,92 +326,92 @@ source-repository-package
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/ouroboros-network
- tag: dae680f8e6b0af611c323554c375f50b3bfd5308
- --sha256: 06431j67milg51ih1wpac829fniw0qlbzzj9vc1xshn445b5vy4n
+ tag: 46e8fd88b0ba071f38891b2b9c6682dc2fb8c865
+ --sha256: 02rgckwkkc705p8f6kh7f882jipgj8xmbz20360grpwhln2cdqgv
  subdir: ouroboros-network
 
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/ouroboros-network
- tag: dae680f8e6b0af611c323554c375f50b3bfd5308
- --sha256: 06431j67milg51ih1wpac829fniw0qlbzzj9vc1xshn445b5vy4n
+ tag: 46e8fd88b0ba071f38891b2b9c6682dc2fb8c865
+ --sha256: 02rgckwkkc705p8f6kh7f882jipgj8xmbz20360grpwhln2cdqgv
  subdir: io-sim
 
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/ouroboros-network
- tag: dae680f8e6b0af611c323554c375f50b3bfd5308
- --sha256: 06431j67milg51ih1wpac829fniw0qlbzzj9vc1xshn445b5vy4n
+ tag: 46e8fd88b0ba071f38891b2b9c6682dc2fb8c865
+ --sha256: 02rgckwkkc705p8f6kh7f882jipgj8xmbz20360grpwhln2cdqgv
  subdir: ouroboros-consensus
 
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/ouroboros-network
- tag: dae680f8e6b0af611c323554c375f50b3bfd5308
- --sha256: 06431j67milg51ih1wpac829fniw0qlbzzj9vc1xshn445b5vy4n
+ tag: 46e8fd88b0ba071f38891b2b9c6682dc2fb8c865
+ --sha256: 02rgckwkkc705p8f6kh7f882jipgj8xmbz20360grpwhln2cdqgv
  subdir: ouroboros-consensus/ouroboros-consensus-mock
 
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/ouroboros-network
- tag: dae680f8e6b0af611c323554c375f50b3bfd5308
- --sha256: 06431j67milg51ih1wpac829fniw0qlbzzj9vc1xshn445b5vy4n
+ tag: 46e8fd88b0ba071f38891b2b9c6682dc2fb8c865
+ --sha256: 02rgckwkkc705p8f6kh7f882jipgj8xmbz20360grpwhln2cdqgv
  subdir: ouroboros-consensus-byron
 
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/ouroboros-network
- tag: dae680f8e6b0af611c323554c375f50b3bfd5308
- --sha256: 06431j67milg51ih1wpac829fniw0qlbzzj9vc1xshn445b5vy4n
+ tag: 46e8fd88b0ba071f38891b2b9c6682dc2fb8c865
+ --sha256: 02rgckwkkc705p8f6kh7f882jipgj8xmbz20360grpwhln2cdqgv
  subdir: ouroboros-consensus-shelley
 
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/ouroboros-network
- tag: dae680f8e6b0af611c323554c375f50b3bfd5308
- --sha256: 06431j67milg51ih1wpac829fniw0qlbzzj9vc1xshn445b5vy4n
+ tag: 46e8fd88b0ba071f38891b2b9c6682dc2fb8c865
+ --sha256: 02rgckwkkc705p8f6kh7f882jipgj8xmbz20360grpwhln2cdqgv
  subdir: ouroboros-consensus-cardano
 
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/ouroboros-network
- tag: dae680f8e6b0af611c323554c375f50b3bfd5308
- --sha256: 06431j67milg51ih1wpac829fniw0qlbzzj9vc1xshn445b5vy4n
+ tag: 46e8fd88b0ba071f38891b2b9c6682dc2fb8c865
+ --sha256: 02rgckwkkc705p8f6kh7f882jipgj8xmbz20360grpwhln2cdqgv
  subdir: typed-protocols
 
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/ouroboros-network
- tag: dae680f8e6b0af611c323554c375f50b3bfd5308
- --sha256: 06431j67milg51ih1wpac829fniw0qlbzzj9vc1xshn445b5vy4n
+ tag: 46e8fd88b0ba071f38891b2b9c6682dc2fb8c865
+ --sha256: 02rgckwkkc705p8f6kh7f882jipgj8xmbz20360grpwhln2cdqgv
  subdir: typed-protocols-examples
 
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/ouroboros-network
- tag: dae680f8e6b0af611c323554c375f50b3bfd5308
- --sha256: 06431j67milg51ih1wpac829fniw0qlbzzj9vc1xshn445b5vy4n
+ tag: 46e8fd88b0ba071f38891b2b9c6682dc2fb8c865
+ --sha256: 02rgckwkkc705p8f6kh7f882jipgj8xmbz20360grpwhln2cdqgv
  subdir: ouroboros-network-framework
 
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/ouroboros-network
- tag: dae680f8e6b0af611c323554c375f50b3bfd5308
- --sha256: 06431j67milg51ih1wpac829fniw0qlbzzj9vc1xshn445b5vy4n
+ tag: 46e8fd88b0ba071f38891b2b9c6682dc2fb8c865
+ --sha256: 02rgckwkkc705p8f6kh7f882jipgj8xmbz20360grpwhln2cdqgv
  subdir: network-mux
 
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/ouroboros-network
- tag: dae680f8e6b0af611c323554c375f50b3bfd5308
- --sha256: 06431j67milg51ih1wpac829fniw0qlbzzj9vc1xshn445b5vy4n
+ tag: 46e8fd88b0ba071f38891b2b9c6682dc2fb8c865
+ --sha256: 02rgckwkkc705p8f6kh7f882jipgj8xmbz20360grpwhln2cdqgv
  subdir: io-sim-classes
 
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/ouroboros-network
- tag: dae680f8e6b0af611c323554c375f50b3bfd5308
- --sha256: 06431j67milg51ih1wpac829fniw0qlbzzj9vc1xshn445b5vy4n
+ tag: 46e8fd88b0ba071f38891b2b9c6682dc2fb8c865
+ --sha256: 02rgckwkkc705p8f6kh7f882jipgj8xmbz20360grpwhln2cdqgv
  subdir: Win32-network
 
 source-repository-package

cardano-api/src/Cardano/Api/Protocol/Byron.hs

@@ -9,18 +9,18 @@ module Cardano.Api.Protocol.Byron
 import Cardano.Chain.Slotting (EpochSlots)
 
 import Ouroboros.Consensus.Cardano
- (ProtocolClient(ProtocolClientRealPBFT), ProtocolRealPBFT,
+ (ProtocolClient(ProtocolClientByron), ProtocolByron,
  SecurityParam)
-import Ouroboros.Consensus.Byron.Ledger (ByronBlock)
+import Ouroboros.Consensus.Cardano.ByronHFC
 
 import Cardano.Api.Protocol.Types (SomeNodeClientProtocol(..))
 
 
 mkNodeClientProtocolByron :: EpochSlots
  -> SecurityParam
- -> ProtocolClient ByronBlock ProtocolRealPBFT
+ -> ProtocolClient ByronBlockHFC ProtocolByron
 mkNodeClientProtocolByron epochSlots securityParam =
- ProtocolClientRealPBFT epochSlots securityParam
+ ProtocolClientByron epochSlots securityParam
 
 
 mkSomeNodeClientProtocolByron :: EpochSlots

cardano-api/src/Cardano/Api/Protocol/Shelley.hs

@@ -8,18 +8,18 @@ module Cardano.Api.Protocol.Shelley
 
 
 import Ouroboros.Consensus.Cardano
- (ProtocolClient(ProtocolClientRealTPraos), ProtocolRealTPraos)
+ (ProtocolClient(ProtocolClientShelley), ProtocolShelley)
+import Ouroboros.Consensus.Cardano.ShelleyHFC
 
-import Ouroboros.Consensus.Shelley.Ledger
 import Ouroboros.Consensus.Shelley.Protocol (TPraosStandardCrypto)
 
 import Cardano.Api.Protocol.Types (SomeNodeClientProtocol(..))
 
 
 mkNodeClientProtocolShelley :: ProtocolClient
- (ShelleyBlock TPraosStandardCrypto)
- ProtocolRealTPraos
-mkNodeClientProtocolShelley = ProtocolClientRealTPraos
+ (ShelleyBlockHFC TPraosStandardCrypto)
+ ProtocolShelley
+mkNodeClientProtocolShelley = ProtocolClientShelley
 
 
 mkSomeNodeClientProtocolShelley :: SomeNodeClientProtocol

cardano-api/src/Cardano/Api/TxSubmit.hs

@@ -1,10 +1,11 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE GADTs #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
 
 module Cardano.Api.TxSubmit
  ( submitTx
@@ -27,6 +28,7 @@ import Ouroboros.Consensus.Cardano.Block
  (GenTx (GenTxByron, GenTxShelley),
  CardanoApplyTxErr, HardForkApplyTxErr (ApplyTxErrByron,
  ApplyTxErrShelley, ApplyTxErrWrongEra))
+import Ouroboros.Consensus.HardFork.Combinator.Degenerate
 
 import Cardano.Api.Typed
 import Cardano.Api.TxSubmit.ErrorRender
@@ -75,18 +77,22 @@ submitTx :: forall mode block.
 submitTx connctInfo txformode =
  case (localNodeConsensusMode connctInfo, txformode) of
  (ByronMode{}, TxForByronMode (ByronTx tx)) -> do
- let genTx = Byron.ByronTx (Byron.byronIdTx tx) tx
+ let genTx = DegenGenTx (Byron.ByronTx (Byron.byronIdTx tx) tx)
  result <- submitTxToNodeLocal connctInfo genTx
  case result of
- SubmitSuccess -> return TxSubmitSuccess
- SubmitFail failure -> return (TxSubmitFailureByronMode failure)
+ SubmitSuccess ->
+ return TxSubmitSuccess
+ SubmitFail (DegenApplyTxErr failure) ->
+ return (TxSubmitFailureByronMode failure)
 
  (ShelleyMode{}, TxForShelleyMode (ShelleyTx tx)) -> do
- let genTx = mkShelleyTx tx
+ let genTx = DegenGenTx (mkShelleyTx tx)
  result <- submitTxToNodeLocal connctInfo genTx
  case result of
- SubmitSuccess -> return TxSubmitSuccess
- SubmitFail failure -> return (TxSubmitFailureShelleyMode failure)
+ SubmitSuccess ->
+ return TxSubmitSuccess
+ SubmitFail (DegenApplyTxErr failure) ->
+ return (TxSubmitFailureShelleyMode failure)
 
  (CardanoMode{}, TxForCardanoMode etx) -> do
  let genTx = case etx of

cardano-api/src/Cardano/Api/Typed.hs

@@ -392,8 +392,8 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion
  supportedNodeToClientVersions)
 import Ouroboros.Consensus.Node.Run (SerialiseNodeToClientConstraints)
 
-import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock)
-import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
+import Ouroboros.Consensus.Cardano.ByronHFC (ByronBlockHFC)
+import Ouroboros.Consensus.Cardano.ShelleyHFC (ShelleyBlockHFC)
 import Ouroboros.Consensus.Cardano.Block (CardanoBlock)
 
 --
@@ -2312,10 +2312,10 @@ data NodeConsensusMode mode block where
  ByronMode
  :: Byron.EpochSlots
  -> SecurityParam
- -> NodeConsensusMode ByronMode ByronBlock
+ -> NodeConsensusMode ByronMode ByronBlockHFC
 
  ShelleyMode
- :: NodeConsensusMode ShelleyMode (ShelleyBlock ShelleyCrypto)
+ :: NodeConsensusMode ShelleyMode (ShelleyBlockHFC ShelleyCrypto)
 
  CardanoMode
  :: Byron.EpochSlots

cardano-cli/src/Cardano/CLI/Byron/Query.hs

@@ -25,6 +25,8 @@ import Cardano.Config.Types (SocketPath (..))
 import Cardano.Api.LocalChainSync (getLocalTip)
 import Cardano.CLI.Environment
  (EnvSocketError, readEnvSocketPath, renderEnvSocketError)
+import Cardano.TracingOrphanInstances.HardFork ()
+
 
 data ByronQueryError
  = ByronQueryEnvVarSocketErr !EnvSocketError

cardano-cli/src/Cardano/CLI/Byron/Tx.hs

@@ -48,6 +48,8 @@ import qualified Cardano.Crypto.Signing as Crypto
 import qualified Ouroboros.Consensus.Byron.Ledger as Byron
 import Ouroboros.Consensus.Byron.Ledger (GenTx(..), ByronBlock)
 import Ouroboros.Consensus.Cardano (SecurityParam(..))
+import Ouroboros.Consensus.HardFork.Combinator.Degenerate
+ (GenTx(DegenGenTx))
 
 import Cardano.Api.Typed
  (NetworkId, LocalNodeConnectInfo(..), NodeConsensusMode(..),
@@ -203,7 +205,7 @@ nodeSubmitTx network gentx = do
  (EpochSlots 21600)
  (SecurityParam 2160)
  }
- _res <- liftIO $ submitTxToNodeLocal connctInfo gentx
+ _res <- liftIO $ submitTxToNodeLocal connctInfo (DegenGenTx gentx)
  --TODO: print failures
  return ()
 

cardano-cli/src/Cardano/CLI/Shelley/Run/Query.hs

@@ -55,6 +55,8 @@ import Cardano.Config.Types (SocketPath(..))
 import Cardano.Binary (decodeFull)
 
 import Ouroboros.Consensus.Cardano.Block (Either (..), EraMismatch (..), Query (..))
+import Ouroboros.Consensus.HardFork.Combinator.Degenerate
+ (Query (DegenQuery), Either (DegenQueryResult))
 import Ouroboros.Consensus.Shelley.Protocol.Crypto (TPraosStandardCrypto)
 import Ouroboros.Network.Block (getTipPoint)
 
@@ -349,10 +351,11 @@ queryUTxOFromLocalState qFilter connectInfo@LocalNodeConnectInfo{localNodeConsen
 
  ShelleyMode{} -> do
  tip <- liftIO $ getLocalTip connectInfo
- firstExceptT AcquireFailureError . newExceptT $
+ DegenQueryResult result <- firstExceptT AcquireFailureError . newExceptT $
  queryNodeLocalState
  connectInfo
- (getTipPoint tip, applyUTxOFilter qFilter)
+ (getTipPoint tip, DegenQuery (applyUTxOFilter qFilter))
+ return result
 
  CardanoMode{} -> do
  tip <- liftIO $ getLocalTip connectInfo
@@ -421,10 +424,11 @@ queryPParamsFromLocalState connectInfo@LocalNodeConnectInfo{
  localNodeConsensusMode = ShelleyMode
  } = do
  tip <- liftIO $ getLocalTip connectInfo
- firstExceptT AcquireFailureError . newExceptT $
+ DegenQueryResult result <- firstExceptT AcquireFailureError . newExceptT $
  queryNodeLocalState
  connectInfo
- (getTipPoint tip, GetCurrentPParams)
+ (getTipPoint tip, DegenQuery GetCurrentPParams)
+ return result
 
 queryPParamsFromLocalState connectInfo@LocalNodeConnectInfo{
  localNodeConsensusMode = CardanoMode{}
@@ -456,10 +460,11 @@ queryStakeDistributionFromLocalState connectInfo@LocalNodeConnectInfo{
  localNodeConsensusMode = ShelleyMode{}
  } = do
  tip <- liftIO $ getLocalTip connectInfo
- firstExceptT AcquireFailureError . newExceptT $
+ DegenQueryResult result <- firstExceptT AcquireFailureError . newExceptT $
  queryNodeLocalState
  connectInfo
- (getTipPoint tip, GetStakeDistribution)
+ (getTipPoint tip, DegenQuery GetStakeDistribution)
+ return result
 
 queryStakeDistributionFromLocalState connectInfo@LocalNodeConnectInfo{
  localNodeConsensusMode = CardanoMode{}
@@ -483,11 +488,14 @@ queryLocalLedgerState connectInfo@LocalNodeConnectInfo{localNodeConsensusMode} =
 
  ShelleyMode{} -> do
  tip <- liftIO $ getLocalTip connectInfo
- fmap decodeLedgerState $
- firstExceptT AcquireFailureError . newExceptT $
+ DegenQueryResult result <- firstExceptT AcquireFailureError . newExceptT $
  queryNodeLocalState
  connectInfo
- (getTipPoint tip, GetCBOR GetCurrentEpochState) -- Get CBOR-in-CBOR version
+ ( getTipPoint tip
+ , DegenQuery $
+ GetCBOR GetCurrentEpochState -- Get CBOR-in-CBOR version
+ )
+ return (decodeLedgerState result)
 
  CardanoMode{} -> do
  tip <- liftIO $ getLocalTip connectInfo
@@ -523,12 +531,16 @@ queryDelegationsAndRewardsFromLocalState stakeaddrs
 
  ShelleyMode{} -> do
  tip <- liftIO $ getLocalTip connectInfo
- fmap (uncurry toDelegsAndRwds) $
+ DegenQueryResult result <-
  firstExceptT AcquireFailureError . newExceptT $
  queryNodeLocalState
  connectInfo
- (getTipPoint tip, GetFilteredDelegationsAndRewardAccounts
- (toShelleyStakeCredentials stakeaddrs))
+ ( getTipPoint tip
+ , DegenQuery $
+ GetFilteredDelegationsAndRewardAccounts
+ (toShelleyStakeCredentials stakeaddrs)
+ )
+ return (uncurry toDelegsAndRwds result)
 
  CardanoMode{} -> do
  tip <- liftIO $ getLocalTip connectInfo

cardano-config/src/Cardano/Config/LedgerQueries.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 
@@ -10,6 +11,9 @@ import Prelude (Int, error, (.))
 import qualified Data.Map.Strict as Map
 
 import Ouroboros.Consensus.Ledger.Abstract
+import Ouroboros.Consensus.HardFork.Combinator
+import Ouroboros.Consensus.HardFork.Combinator.Unary
+
 import Byron.Spec.Ledger.Core (Relation(..))
 
 import qualified Cardano.Chain.Block as Byron
@@ -37,6 +41,10 @@ instance LedgerQueries (Shelley.ShelleyBlock c) where
  ledgerUtxoSize =
  (\(Shelley.UTxO xs)-> Map.size xs) . Shelley._utxo . Shelley._utxoState . Shelley.esLState . Shelley.nesEs . Shelley.shelleyState
 
+instance (LedgerQueries x, NoHardForks x)
+ => LedgerQueries (HardForkBlock '[x]) where
+ ledgerUtxoSize = ledgerUtxoSize . project
+
 instance LedgerQueries (Cardano.CardanoBlock c) where
  ledgerUtxoSize = \case
  Cardano.LedgerStateByron ledgerByron -> ledgerUtxoSize ledgerByron