{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_GHC -Wno-orphans  #-}

-- DUPLICATE -- adapted from: cardano-node/src/Cardano/Node/Protocol/Cardano.hs

module Cardano.Node.Protocol.Cardano (
    mkConsensusProtocolCardano
  , mkSomeConsensusProtocolCardano
    -- * Errors
  , CardanoProtocolInstantiationError (..)
  ) where

import           Cardano.Api.Any
import           Cardano.Api.Protocol.Types
import qualified Cardano.Chain.Update as Byron
import qualified Cardano.Ledger.Api.Era as L
import qualified Cardano.Ledger.Api.Transition as SL
import qualified Cardano.Node.Protocol.Alonzo as Alonzo
import qualified Cardano.Node.Protocol.Byron as Byron
import qualified Cardano.Node.Protocol.Conway as Conway
import qualified Cardano.Node.Protocol.Shelley as Shelley
import           Cardano.Node.Protocol.Types
import           Cardano.Node.Types
import           Control.Monad.Trans.Except (ExceptT)
import           Control.Monad.Trans.Except.Extra (firstExceptT)
import           Ouroboros.Consensus.Cardano
import qualified Ouroboros.Consensus.Cardano as Consensus
import           Ouroboros.Consensus.Cardano.Condense ()
import           Ouroboros.Consensus.Cardano.Node (CardanoProtocolParams (..))
import           Ouroboros.Consensus.Config (emptyCheckpointsMap)
import           Ouroboros.Consensus.HardFork.Combinator.Condense ()
import           Ouroboros.Consensus.Shelley.Crypto (StandardCrypto)


------------------------------------------------------------------------------
-- Real Cardano protocol
--

-- | Make 'SomeConsensusProtocol' using the Cardano instance.
--
-- The Cardano protocol instance is currently the sequential composition of
-- the Byron and Shelley protocols, and will likely be extended in future
-- with further sequentially composed protocol revisions.
--
-- The use of 'SomeConsensusProtocol' lets us handle multiple protocols in a
-- generic way.
--
-- This also serves a purpose as a sanity check that we have all the necessary
-- type class instances available.
--
mkSomeConsensusProtocolCardano ::
     NodeByronProtocolConfiguration
  -> NodeShelleyProtocolConfiguration
  -> NodeAlonzoProtocolConfiguration
  -> NodeConwayProtocolConfiguration
  -> NodeHardForkProtocolConfiguration
  -> Maybe ProtocolFilepaths
  -> ExceptT CardanoProtocolInstantiationError IO SomeConsensusProtocol
mkSomeConsensusProtocolCardano :: NodeByronProtocolConfiguration
-> NodeShelleyProtocolConfiguration
-> NodeAlonzoProtocolConfiguration
-> NodeConwayProtocolConfiguration
-> NodeHardForkProtocolConfiguration
-> Maybe ProtocolFilepaths
-> ExceptT
     CardanoProtocolInstantiationError IO SomeConsensusProtocol
mkSomeConsensusProtocolCardano NodeByronProtocolConfiguration
nbpc NodeShelleyProtocolConfiguration
nspc NodeAlonzoProtocolConfiguration
napc NodeConwayProtocolConfiguration
ncpc NodeHardForkProtocolConfiguration
nhpc Maybe ProtocolFilepaths
files = do
    params <- NodeByronProtocolConfiguration
-> NodeShelleyProtocolConfiguration
-> NodeAlonzoProtocolConfiguration
-> NodeConwayProtocolConfiguration
-> NodeHardForkProtocolConfiguration
-> Maybe ProtocolFilepaths
-> ExceptT
     CardanoProtocolInstantiationError
     IO
     (CardanoProtocolParams StandardCrypto)
mkConsensusProtocolCardano NodeByronProtocolConfiguration
nbpc NodeShelleyProtocolConfiguration
nspc NodeAlonzoProtocolConfiguration
napc NodeConwayProtocolConfiguration
ncpc NodeHardForkProtocolConfiguration
nhpc Maybe ProtocolFilepaths
files
    return $!
      SomeConsensusProtocol CardanoBlockType $ ProtocolInfoArgsCardano params

mkConsensusProtocolCardano ::
     NodeByronProtocolConfiguration
  -> NodeShelleyProtocolConfiguration
  -> NodeAlonzoProtocolConfiguration
  -> NodeConwayProtocolConfiguration
  -> NodeHardForkProtocolConfiguration
  -> Maybe ProtocolFilepaths
  -> ExceptT CardanoProtocolInstantiationError IO (CardanoProtocolParams StandardCrypto)
mkConsensusProtocolCardano :: NodeByronProtocolConfiguration
-> NodeShelleyProtocolConfiguration
-> NodeAlonzoProtocolConfiguration
-> NodeConwayProtocolConfiguration
-> NodeHardForkProtocolConfiguration
-> Maybe ProtocolFilepaths
-> ExceptT
     CardanoProtocolInstantiationError
     IO
     (CardanoProtocolParams StandardCrypto)
mkConsensusProtocolCardano NodeByronProtocolConfiguration {
                             GenesisFile
npcByronGenesisFile :: GenesisFile
npcByronGenesisFile :: NodeByronProtocolConfiguration -> GenesisFile
npcByronGenesisFile,
                             Maybe GenesisHash
npcByronGenesisFileHash :: Maybe GenesisHash
npcByronGenesisFileHash :: NodeByronProtocolConfiguration -> Maybe GenesisHash
npcByronGenesisFileHash,
                             RequiresNetworkMagic
npcByronReqNetworkMagic :: RequiresNetworkMagic
npcByronReqNetworkMagic :: NodeByronProtocolConfiguration -> RequiresNetworkMagic
npcByronReqNetworkMagic,
                             Maybe Double
npcByronPbftSignatureThresh :: Maybe Double
npcByronPbftSignatureThresh :: NodeByronProtocolConfiguration -> Maybe Double
npcByronPbftSignatureThresh,
                             ApplicationName
npcByronApplicationName :: ApplicationName
npcByronApplicationName :: NodeByronProtocolConfiguration -> ApplicationName
npcByronApplicationName,
                             NumSoftwareVersion
npcByronApplicationVersion :: NumSoftwareVersion
npcByronApplicationVersion :: NodeByronProtocolConfiguration -> NumSoftwareVersion
npcByronApplicationVersion,
                             Word16
npcByronSupportedProtocolVersionMajor :: Word16
npcByronSupportedProtocolVersionMajor :: NodeByronProtocolConfiguration -> Word16
npcByronSupportedProtocolVersionMajor,
                             Word16
npcByronSupportedProtocolVersionMinor :: Word16
npcByronSupportedProtocolVersionMinor :: NodeByronProtocolConfiguration -> Word16
npcByronSupportedProtocolVersionMinor,
                             Word8
npcByronSupportedProtocolVersionAlt :: Word8
npcByronSupportedProtocolVersionAlt :: NodeByronProtocolConfiguration -> Word8
npcByronSupportedProtocolVersionAlt
                           }
                           NodeShelleyProtocolConfiguration {
                             GenesisFile
npcShelleyGenesisFile :: GenesisFile
npcShelleyGenesisFile :: NodeShelleyProtocolConfiguration -> GenesisFile
npcShelleyGenesisFile,
                             Maybe GenesisHash
npcShelleyGenesisFileHash :: Maybe GenesisHash
npcShelleyGenesisFileHash :: NodeShelleyProtocolConfiguration -> Maybe GenesisHash
npcShelleyGenesisFileHash
                           }
                           NodeAlonzoProtocolConfiguration {
                             GenesisFile
npcAlonzoGenesisFile :: GenesisFile
npcAlonzoGenesisFile :: NodeAlonzoProtocolConfiguration -> GenesisFile
npcAlonzoGenesisFile,
                             Maybe GenesisHash
npcAlonzoGenesisFileHash :: Maybe GenesisHash
npcAlonzoGenesisFileHash :: NodeAlonzoProtocolConfiguration -> Maybe GenesisHash
npcAlonzoGenesisFileHash
                           }
                           NodeConwayProtocolConfiguration {
                             GenesisFile
npcConwayGenesisFile :: GenesisFile
npcConwayGenesisFile :: NodeConwayProtocolConfiguration -> GenesisFile
npcConwayGenesisFile,
                             Maybe GenesisHash
npcConwayGenesisFileHash :: Maybe GenesisHash
npcConwayGenesisFileHash :: NodeConwayProtocolConfiguration -> Maybe GenesisHash
npcConwayGenesisFileHash
                           }
                           NodeHardForkProtocolConfiguration {
                            npcTestEnableDevelopmentHardForkEras :: NodeHardForkProtocolConfiguration -> Bool
npcTestEnableDevelopmentHardForkEras = Bool
_,
                            -- During testing of the latest unreleased era, we conditionally
                            -- declared that we knew about it. We do so only when a config option
                            -- for testing development/unstable eras is used. This lets us include
                            -- not-yet-ready eras in released node versions without mainnet nodes
                            -- prematurely advertising that they could hard fork into the new era.
                             Maybe EpochNo
npcTestShelleyHardForkAtEpoch :: Maybe EpochNo
npcTestShelleyHardForkAtEpoch :: NodeHardForkProtocolConfiguration -> Maybe EpochNo
npcTestShelleyHardForkAtEpoch,
                             Maybe EpochNo
npcTestAllegraHardForkAtEpoch :: Maybe EpochNo
npcTestAllegraHardForkAtEpoch :: NodeHardForkProtocolConfiguration -> Maybe EpochNo
npcTestAllegraHardForkAtEpoch,
                             Maybe EpochNo
npcTestMaryHardForkAtEpoch :: Maybe EpochNo
npcTestMaryHardForkAtEpoch :: NodeHardForkProtocolConfiguration -> Maybe EpochNo
npcTestMaryHardForkAtEpoch,
                             Maybe EpochNo
npcTestAlonzoHardForkAtEpoch :: Maybe EpochNo
npcTestAlonzoHardForkAtEpoch :: NodeHardForkProtocolConfiguration -> Maybe EpochNo
npcTestAlonzoHardForkAtEpoch,
                             Maybe EpochNo
npcTestBabbageHardForkAtEpoch :: Maybe EpochNo
npcTestBabbageHardForkAtEpoch :: NodeHardForkProtocolConfiguration -> Maybe EpochNo
npcTestBabbageHardForkAtEpoch,
                             Maybe EpochNo
npcTestConwayHardForkAtEpoch :: Maybe EpochNo
npcTestConwayHardForkAtEpoch :: NodeHardForkProtocolConfiguration -> Maybe EpochNo
npcTestConwayHardForkAtEpoch
                           }
                           Maybe ProtocolFilepaths
files = do
    byronGenesis <-
      (ByronProtocolInstantiationError
 -> CardanoProtocolInstantiationError)
-> ExceptT ByronProtocolInstantiationError IO Config
-> ExceptT CardanoProtocolInstantiationError IO Config
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT ByronProtocolInstantiationError
-> CardanoProtocolInstantiationError
CardanoProtocolInstantiationErrorByron (ExceptT ByronProtocolInstantiationError IO Config
 -> ExceptT CardanoProtocolInstantiationError IO Config)
-> ExceptT ByronProtocolInstantiationError IO Config
-> ExceptT CardanoProtocolInstantiationError IO Config
forall a b. (a -> b) -> a -> b
$
        GenesisFile
-> Maybe GenesisHash
-> RequiresNetworkMagic
-> ExceptT ByronProtocolInstantiationError IO Config
Byron.readGenesis GenesisFile
npcByronGenesisFile
                          Maybe GenesisHash
npcByronGenesisFileHash
                          RequiresNetworkMagic
npcByronReqNetworkMagic

    byronLeaderCredentials <-
      firstExceptT CardanoProtocolInstantiationErrorByron $
        Byron.readLeaderCredentials byronGenesis files

    (shelleyGenesis, shelleyGenesisHash) <-
      firstExceptT CardanoProtocolInstantiationShelleyGenesisReadError $
        Shelley.readGenesis npcShelleyGenesisFile
                            npcShelleyGenesisFileHash

    (alonzoGenesis, _alonzoGenesisHash) <-
      firstExceptT CardanoProtocolInstantiationAlonzoGenesisReadError $
        Alonzo.readGenesis npcAlonzoGenesisFile
                           npcAlonzoGenesisFileHash

    (conwayGenesis, _conwayGenesisHash) <-
      firstExceptT CardanoProtocolInstantiationConwayGenesisReadError $
        Conway.readGenesis npcConwayGenesisFile
                           npcConwayGenesisFileHash

    shelleyLeaderCredentials <-
      firstExceptT CardanoProtocolInstantiationPraosLeaderCredentialsError $
        Shelley.readLeaderCredentials files

    let transitionLedgerConfig =
          ShelleyGenesis
-> AlonzoGenesis
-> ConwayGenesis
-> TransitionConfig LatestKnownEra
SL.mkLatestTransitionConfig ShelleyGenesis
shelleyGenesis AlonzoGenesis
alonzoGenesis ConwayGenesis
conwayGenesis

    --TODO: all these protocol versions below are confusing and unnecessary.
    -- It could and should all be automated and these config entries eliminated.
    return $!
      CardanoProtocolParams
        Consensus.ProtocolParamsByron {
          byronGenesis = byronGenesis,
          byronPbftSignatureThreshold =
            PBftSignatureThreshold <$> npcByronPbftSignatureThresh,

          -- This is /not/ the Byron protocol version. It is the protocol
          -- version that this node will use in blocks it creates. It is used
          -- in the Byron update mechanism to signal that this block-producing
          -- node is ready to move to the new protocol. For example, when the
          -- protocol version (according to the ledger state) is 0, this setting
          -- should be 1 when we are ready to move. Similarly when the current
          -- protocol version is 1, this should be 2 to indicate we are ready
          -- to move into the Shelley era.
          byronProtocolVersion =
            Byron.ProtocolVersion
              npcByronSupportedProtocolVersionMajor
              npcByronSupportedProtocolVersionMinor
              npcByronSupportedProtocolVersionAlt,
          byronSoftwareVersion =
            Byron.SoftwareVersion
              npcByronApplicationName
              npcByronApplicationVersion,
          byronLeaderCredentials = byronLeaderCredentials
        }
        Consensus.ProtocolParamsShelleyBased {
          shelleyBasedInitialNonce      = Shelley.genesisHashToPraosNonce
                                            shelleyGenesisHash,
          shelleyBasedLeaderCredentials = shelleyLeaderCredentials
        }
        -- The 'CardanoHardForkTriggers' specify the parameters needed to
        -- transition between two eras. The comments below also apply for all
        -- subsequent hard forks.
        --
        -- Byron to Shelley hard fork parameters
        Consensus.CardanoHardForkTriggers' {
          triggerHardForkShelley =
            -- What will trigger the Byron -> Shelley hard fork?
            case npcTestShelleyHardForkAtEpoch of

              -- This specifies the major protocol version number update that will
              -- trigger us moving to the Shelley protocol.
              --
              -- Version 0 is Byron with Ouroboros classic
              -- Version 1 is Byron with Ouroboros Permissive BFT
              -- Version 2 is Shelley
              -- Version 3 is Allegra
              -- Version 4 is Mary
              -- Version 5 is Alonzo
              -- Version 6 is Alonzo (intra era hardfork)
              -- Version 7 is Babbage
              -- Version 8 is Babbage (intra era hardfork)
              -- Version 9 is Conway
              --
              -- But we also provide an override to allow for simpler test setups
              -- such as triggering at the 0 -> 1 transition .
              --
              Maybe EpochNo
Nothing      -> CardanoHardForkTrigger
  (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)
forall blk. CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtDefaultVersion

              -- Alternatively, for testing we can transition at a specific epoch.
              --
              Just EpochNo
epochNo -> EpochNo
-> CardanoHardForkTrigger
     (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)
forall blk. EpochNo -> CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtEpoch EpochNo
epochNo
          -- Shelley to Allegra hard fork parameters
        , triggerHardForkAllegra =
            case npcTestAllegraHardForkAtEpoch of
              Maybe EpochNo
Nothing      -> CardanoHardForkTrigger
  (ShelleyBlock (TPraos StandardCrypto) AllegraEra)
forall blk. CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtDefaultVersion
              Just EpochNo
epochNo -> EpochNo
-> CardanoHardForkTrigger
     (ShelleyBlock (TPraos StandardCrypto) AllegraEra)
forall blk. EpochNo -> CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtEpoch EpochNo
epochNo
          -- Allegra to Mary hard fork parameters
        , triggerHardForkMary =
            case npcTestMaryHardForkAtEpoch of
              Maybe EpochNo
Nothing      -> CardanoHardForkTrigger
  (ShelleyBlock (TPraos StandardCrypto) MaryEra)
forall blk. CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtDefaultVersion
              Just EpochNo
epochNo -> EpochNo
-> CardanoHardForkTrigger
     (ShelleyBlock (TPraos StandardCrypto) MaryEra)
forall blk. EpochNo -> CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtEpoch EpochNo
epochNo
          -- Mary to Alonzo hard fork parameters
        , triggerHardForkAlonzo =
            case npcTestAlonzoHardForkAtEpoch of
              Maybe EpochNo
Nothing      -> CardanoHardForkTrigger
  (ShelleyBlock (TPraos StandardCrypto) AlonzoEra)
forall blk. CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtDefaultVersion
              Just EpochNo
epochNo -> EpochNo
-> CardanoHardForkTrigger
     (ShelleyBlock (TPraos StandardCrypto) AlonzoEra)
forall blk. EpochNo -> CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtEpoch EpochNo
epochNo
          -- Alonzo to Babbage hard fork parameters
        , triggerHardForkBabbage =
            case npcTestBabbageHardForkAtEpoch of
                Maybe EpochNo
Nothing      -> CardanoHardForkTrigger
  (ShelleyBlock (Praos StandardCrypto) BabbageEra)
forall blk. CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtDefaultVersion
                Just EpochNo
epochNo -> EpochNo
-> CardanoHardForkTrigger
     (ShelleyBlock (Praos StandardCrypto) BabbageEra)
forall blk. EpochNo -> CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtEpoch EpochNo
epochNo
          -- Babbage to Conway hard fork parameters
        , triggerHardForkConway =
            case npcTestConwayHardForkAtEpoch of
                Maybe EpochNo
Nothing      -> CardanoHardForkTrigger
  (ShelleyBlock (Praos StandardCrypto) LatestKnownEra)
forall blk. CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtDefaultVersion
                Just EpochNo
epochNo -> EpochNo
-> CardanoHardForkTrigger
     (ShelleyBlock (Praos StandardCrypto) LatestKnownEra)
forall blk. EpochNo -> CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtEpoch EpochNo
epochNo
        }
        transitionLedgerConfig
        emptyCheckpointsMap
        (ProtVer (L.eraProtVerHigh @L.LatestKnownEra) 0)

------------------------------------------------------------------------------
-- Errors
--

data CardanoProtocolInstantiationError =
       CardanoProtocolInstantiationErrorByron
         Byron.ByronProtocolInstantiationError

     | CardanoProtocolInstantiationShelleyGenesisReadError
         Shelley.GenesisReadError

     | CardanoProtocolInstantiationAlonzoGenesisReadError
         Shelley.GenesisReadError

     | CardanoProtocolInstantiationConwayGenesisReadError
         Shelley.GenesisReadError

     | CardanoProtocolInstantiationPraosLeaderCredentialsError
         Shelley.PraosLeaderCredentialsError

     | CardanoProtocolInstantiationErrorAlonzo
         Alonzo.AlonzoProtocolInstantiationError
  deriving Int -> CardanoProtocolInstantiationError -> ShowS
[CardanoProtocolInstantiationError] -> ShowS
CardanoProtocolInstantiationError -> String
(Int -> CardanoProtocolInstantiationError -> ShowS)
-> (CardanoProtocolInstantiationError -> String)
-> ([CardanoProtocolInstantiationError] -> ShowS)
-> Show CardanoProtocolInstantiationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CardanoProtocolInstantiationError -> ShowS
showsPrec :: Int -> CardanoProtocolInstantiationError -> ShowS
$cshow :: CardanoProtocolInstantiationError -> String
show :: CardanoProtocolInstantiationError -> String
$cshowList :: [CardanoProtocolInstantiationError] -> ShowS
showList :: [CardanoProtocolInstantiationError] -> ShowS
Show

instance Error CardanoProtocolInstantiationError where
  displayError :: CardanoProtocolInstantiationError -> String
displayError (CardanoProtocolInstantiationErrorByron ByronProtocolInstantiationError
err) =
    ByronProtocolInstantiationError -> String
forall e. Error e => e -> String
displayError ByronProtocolInstantiationError
err
  displayError (CardanoProtocolInstantiationShelleyGenesisReadError GenesisReadError
err) =
    String
"Shelley related: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> GenesisReadError -> String
forall e. Error e => e -> String
displayError GenesisReadError
err
  displayError (CardanoProtocolInstantiationAlonzoGenesisReadError GenesisReadError
err) =
    String
"Alonzo related: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> GenesisReadError -> String
forall e. Error e => e -> String
displayError GenesisReadError
err
  displayError (CardanoProtocolInstantiationConwayGenesisReadError GenesisReadError
err) =
    String
"Conway related: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> GenesisReadError -> String
forall e. Error e => e -> String
displayError GenesisReadError
err
  displayError (CardanoProtocolInstantiationPraosLeaderCredentialsError PraosLeaderCredentialsError
err) =
    PraosLeaderCredentialsError -> String
forall e. Error e => e -> String
displayError PraosLeaderCredentialsError
err
  displayError (CardanoProtocolInstantiationErrorAlonzo AlonzoProtocolInstantiationError
err) =
    AlonzoProtocolInstantiationError -> String
forall e. Error e => e -> String
displayError AlonzoProtocolInstantiationError
err