{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | How the tools in this package handle the node configuration.
--
-- Parsing it and loading the genesis files it names is @cardano-config@'s job.
-- Left for here is what building a Cardano 'ProtocolInfo' still needs derived
-- from the result: the hard-fork triggers, the initial nonce, the protocol
-- version and the ledger transition configuration. Both db-analyser and
-- db-synthesizer go through this module, so the two read a configuration file
-- the same way.
module Cardano.Tools.Config
  ( -- * Reading the node configuration
    resolveNodeConfiguration
  , resolveNodeConfigurationWith
  , reportConfigWarnings

    -- * Interpreting the node configuration
  , mkHardForkTriggers
  , mkDijkstraGenesis
  , mkInitialNonce
  , mkProtocolVersion
  , mkTransitionConfig

    -- * Configuration errors
  , ConfigError (..)
  , throwConfigError
  , withConfigErrorHandling
  ) where

import qualified Cardano.Configuration as Cfg
import qualified Cardano.Configuration.CliArgs as CLI
import qualified Cardano.Crypto.Hash.Class as CryptoClass
import qualified Cardano.Ledger.Api.Era as L
import qualified Cardano.Ledger.Api.Transition as SL
import Cardano.Ledger.BaseTypes
  ( Milliseconds32 (..)
  , Nonce (..)
  , ProtVer (..)
  , boundRational
  , unsafeNonZero
  )
import Cardano.Ledger.Coin (Coin (..), CoinPerByte (..), CompactForm (..))
import Cardano.Ledger.Core (MaxPledgeLeverage (..))
import Cardano.Ledger.Dijkstra.PParams
import Cardano.Ledger.Plutus
  ( ExUnits (..)
  , Language (..)
  , OrdExUnits (..)
  , costModelInitParamCount
  , mkCostModel
  )
import Cardano.Slotting.Slot (EpochNo (..), SlotInterval (..))
import Control.Exception (Exception (..), handle, throwIO, try)
import Data.Either (fromRight)
import Data.Functor.Identity (Identity, runIdentity)
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Maybe.Strict (StrictMaybe (..), strictMaybe, strictMaybeToMaybe)
import Data.Word (Word16, Word64)
import Ouroboros.Consensus.Cardano.Node
  ( CardanoHardForkTrigger (..)
  , CardanoHardForkTriggers (..)
  )
import System.Environment (getProgName)
import System.Exit (exitFailure)
import System.IO (hPutStrLn, stderr)

--
-- Configuration errors
--

-- | A tool was invoked with a configuration it cannot work with, be it in the
-- node configuration file or on the command line.
newtype ConfigError = ConfigError String
  deriving Int -> ConfigError -> ShowS
[ConfigError] -> ShowS
ConfigError -> [Char]
(Int -> ConfigError -> ShowS)
-> (ConfigError -> [Char])
-> ([ConfigError] -> ShowS)
-> Show ConfigError
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfigError -> ShowS
showsPrec :: Int -> ConfigError -> ShowS
$cshow :: ConfigError -> [Char]
show :: ConfigError -> [Char]
$cshowList :: [ConfigError] -> ShowS
showList :: [ConfigError] -> ShowS
Show

instance Exception ConfigError where
  -- Deliberately just the message: these are user errors, so neither a call
  -- stack nor a @user error (..)@ wrapper would tell the user anything useful.
  displayException :: ConfigError -> [Char]
displayException (ConfigError [Char]
msg) = [Char]
msg

-- | Abort because of a 'ConfigError'.
--
-- Every configuration problem these tools detect is reported this way, so that
-- they all reach the user in the same shape.
throwConfigError :: String -> IO a
throwConfigError :: forall a. [Char] -> IO a
throwConfigError = ConfigError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (ConfigError -> IO a) -> ([Char] -> ConfigError) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ConfigError
ConfigError

-- | Report an escaping 'ConfigError' as a plain @\<prog\>: \<message\>@ on
-- stderr and exit with a failure.
--
-- Wrap a tool's @main@ in this. GHC's default handler would otherwise bury the
-- message under the exception's qualified type name and a call-stack backtrace.
withConfigErrorHandling :: IO a -> IO a
withConfigErrorHandling :: forall a. IO a -> IO a
withConfigErrorHandling =
  (ConfigError -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ((ConfigError -> IO a) -> IO a -> IO a)
-> (ConfigError -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ \(ConfigError [Char]
msg) -> do
    prog <- IO [Char]
getProgName
    hPutStrLn stderr $ prog <> ": " <> msg
    exitFailure

--
-- Reading the node configuration
--

-- | Parse and resolve the node configuration with the shared 'cardano-config'
-- package, with no command-line overrides: every value comes from the
-- configuration file (and cardano-config's own defaults layer).
--
-- The warnings emitted while resolving are returned rather than reported here,
-- so that the caller decides where they are printed.
resolveNodeConfiguration :: FilePath -> IO (Cfg.NodeConfiguration, [Cfg.ConfigWarning])
resolveNodeConfiguration :: [Char] -> IO (NodeConfiguration, [ConfigWarning])
resolveNodeConfiguration = CliArgs -> IO (NodeConfiguration, [ConfigWarning])
resolveNodeConfigurationWith (CliArgs -> IO (NodeConfiguration, [ConfigWarning]))
-> ([Char] -> CliArgs)
-> [Char]
-> IO (NodeConfiguration, [ConfigWarning])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> CliArgs
CLI.defaultCliArgs

-- | As 'resolveNodeConfiguration', but resolving the configuration file named
-- by the given command-line arguments against them, so that a tool that has
-- command-line options of its own (db-synthesizer and its credentials) can
-- override what the file says. 'CLI.defaultCliArgs' is the starting point for
-- building those arguments.
resolveNodeConfigurationWith ::
  CLI.CliArgs -> IO (Cfg.NodeConfiguration, [Cfg.ConfigWarning])
resolveNodeConfigurationWith :: CliArgs -> IO (NodeConfiguration, [ConfigWarning])
resolveNodeConfigurationWith CliArgs
cliArgs =
  -- cardano-config reports some problems by throwing rather than in its result,
  -- a missing mandatory key notably, so catch those too. Letting them escape
  -- would show a call-stack backtrace for a mistake in a configuration file.
  IO
  (Either ConfigResolutionError (NodeConfiguration, [ConfigWarning]))
-> IO
     (Either
        ConfigurationParsingError
        (Either
           ConfigResolutionError (NodeConfiguration, [ConfigWarning])))
forall e a. Exception e => IO a -> IO (Either e a)
try IO
  (Either ConfigResolutionError (NodeConfiguration, [ConfigWarning]))
resolve IO
  (Either
     ConfigurationParsingError
     (Either
        ConfigResolutionError (NodeConfiguration, [ConfigWarning])))
-> (Either
      ConfigurationParsingError
      (Either ConfigResolutionError (NodeConfiguration, [ConfigWarning]))
    -> IO (NodeConfiguration, [ConfigWarning]))
-> IO (NodeConfiguration, [ConfigWarning])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (ConfigurationParsingError
err :: Cfg.ConfigurationParsingError) -> [Char] -> IO (NodeConfiguration, [ConfigWarning])
forall a. [Char] -> IO a
invalid (ConfigurationParsingError -> [Char]
forall e. Exception e => e -> [Char]
displayException ConfigurationParsingError
err)
    Right (Left ConfigResolutionError
err) -> [Char] -> IO (NodeConfiguration, [ConfigWarning])
forall a. [Char] -> IO a
invalid (ConfigResolutionError -> [Char]
forall a. Show a => a -> [Char]
show ConfigResolutionError
err)
    Right (Right (NodeConfiguration, [ConfigWarning])
res) -> (NodeConfiguration, [ConfigWarning])
-> IO (NodeConfiguration, [ConfigWarning])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeConfiguration, [ConfigWarning])
res
 where
  resolve :: IO
  (Either ConfigResolutionError (NodeConfiguration, [ConfigWarning]))
resolve = do
    (fileCfg, fileWarnings) <- HasCallStack =>
[Char] -> IO (NodeConfigurationFromFile, [ConfigWarning])
[Char] -> IO (NodeConfigurationFromFile, [ConfigWarning])
Cfg.parseConfigurationFiles (CliArgs -> [Char]
CLI.configFilePath CliArgs
cliArgs)
    pure $ case Cfg.resolveConfiguration cliArgs fileCfg of
      Left ConfigResolutionError
err -> ConfigResolutionError
-> Either
     ConfigResolutionError (NodeConfiguration, [ConfigWarning])
forall a b. a -> Either a b
Left ConfigResolutionError
err
      Right (NodeConfiguration
nc, [ConfigWarning]
checkWarnings) -> (NodeConfiguration, [ConfigWarning])
-> Either
     ConfigResolutionError (NodeConfiguration, [ConfigWarning])
forall a b. b -> Either a b
Right (NodeConfiguration
nc, [ConfigWarning]
fileWarnings [ConfigWarning] -> [ConfigWarning] -> [ConfigWarning]
forall a. Semigroup a => a -> a -> a
<> [ConfigWarning]
checkWarnings)

  invalid :: [Char] -> IO a
invalid [Char]
msg = [Char] -> IO a
forall a. [Char] -> IO a
throwConfigError ([Char]
"invalid node configuration: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
msg)

-- | Report the warnings raised while resolving a node configuration on stderr.
--
-- A tool carries on afterwards, but they say that some of what the file asks for
-- was not honoured, which is worth seeing before its own output starts.
reportConfigWarnings :: [Cfg.ConfigWarning] -> IO ()
reportConfigWarnings :: [ConfigWarning] -> IO ()
reportConfigWarnings =
  (ConfigWarning -> IO ()) -> [ConfigWarning] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ())
-> (ConfigWarning -> [Char]) -> ConfigWarning -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"WARNING: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> (ConfigWarning -> [Char]) -> ConfigWarning -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigWarning -> [Char]
Cfg.renderConfigWarning)

--
-- Interpreting the node configuration
--

-- | The initial nonce, ie the Blake2b-256 hash of the Shelley genesis file,
-- which 'cardano-config' records alongside the file path.
mkInitialNonce :: Cfg.NodeConfiguration -> Nonce
mkInitialNonce :: NodeConfiguration -> Nonce
mkInitialNonce NodeConfiguration
nc =
  Hash Blake2b_256 Nonce -> Nonce
Nonce (Hash Blake2b_256 Nonce -> Nonce)
-> Hash Blake2b_256 Nonce -> Nonce
forall a b. (a -> b) -> a -> b
$
    Hash Blake2b_256 ByteString -> Hash Blake2b_256 Nonce
forall h a b. Hash h a -> Hash h b
CryptoClass.castHash (Hash Blake2b_256 ByteString -> Hash Blake2b_256 Nonce)
-> Hash Blake2b_256 ByteString -> Hash Blake2b_256 Nonce
forall a b. (a -> b) -> a -> b
$
      Hashed [Char] -> Hash Blake2b_256 ByteString
forall a. Hashed a -> Hash Blake2b_256 ByteString
Cfg.hash (ProtocolConfiguration Identity -> Hashed [Char]
forall (f :: * -> *). ProtocolConfiguration f -> Hashed [Char]
Cfg.shelleyGenesis (NodeConfiguration -> ProtocolConfiguration Identity
Cfg.protocolConfiguration NodeConfiguration
nc))

-- | The ledger transition configuration, ie the genesis of every Shelley-based
-- era, as parsed by 'cardano-config'.
mkTransitionConfig :: Cfg.NodeConfiguration -> SL.TransitionConfig L.LatestKnownEra
mkTransitionConfig :: NodeConfiguration -> TransitionConfig LatestKnownEra
mkTransitionConfig NodeConfiguration
nc =
  ShelleyGenesis
-> AlonzoGenesis
-> ConwayGenesis
-> DijkstraGenesis
-> TransitionConfig LatestKnownEra
SL.mkLatestTransitionConfig
    (NodeConfiguration -> ShelleyGenesis
Cfg.shelleyGenesisConfig NodeConfiguration
nc)
    (NodeConfiguration -> AlonzoGenesis
Cfg.alonzoGenesisConfig NodeConfiguration
nc)
    (NodeConfiguration -> ConwayGenesis
Cfg.conwayGenesisConfig NodeConfiguration
nc)
    (NodeConfiguration -> DijkstraGenesis
mkDijkstraGenesis NodeConfiguration
nc)

-- | The greatest protocol version the tools forge in and validate.
--
-- As in cardano-node, @ExperimentalHardForksEnabled@ decides it: the flag admits
-- the experimental era, so with it off the version stops at the era before.
--
-- The eras are named rather than written as the 12 and 11 they currently are, so
-- that adding an era moves both.
mkProtocolVersion :: Cfg.NodeConfiguration -> ProtVer
mkProtocolVersion :: NodeConfiguration -> ProtVer
mkProtocolVersion NodeConfiguration
nc
  | NodeConfiguration -> Bool
experimentalErasEnabled NodeConfiguration
nc = Version -> Word32 -> ProtVer
ProtVer (forall era. Era era => Version
L.eraProtVerHigh @L.LatestKnownEra) Word32
0
  | Bool
otherwise = Version -> Word32 -> ProtVer
ProtVer (forall era. Era era => Version
L.eraProtVerHigh @(L.PreviousEra L.LatestKnownEra)) Word32
0

-- | The Dijkstra genesis to build the transition configuration from.
--
-- A transition configuration needs one for every Shelley-based era, including
-- eras a chain never reaches, but a configuration need not name a
-- @DijkstraGenesisFile@. @cardano-config@ reports what the file says without
-- inventing values, so the fallback is ours.
--
-- Whether the file applies at all is decided upstream: @cardano-config@ gates it
-- on @ExperimentalHardForksEnabled@ as cardano-node does, reporting 'SNothing'
-- with the flag off without opening the file. Gating again here would put the
-- rule in two places.
mkDijkstraGenesis :: Cfg.NodeConfiguration -> SL.DijkstraGenesis
mkDijkstraGenesis :: NodeConfiguration -> DijkstraGenesis
mkDijkstraGenesis =
  DijkstraGenesis
-> (DijkstraGenesis -> DijkstraGenesis)
-> StrictMaybe DijkstraGenesis
-> DijkstraGenesis
forall a b. a -> (b -> a) -> StrictMaybe b -> a
strictMaybe DijkstraGenesis
defaultDijkstraGenesis DijkstraGenesis -> DijkstraGenesis
forall a. a -> a
id (StrictMaybe DijkstraGenesis -> DijkstraGenesis)
-> (NodeConfiguration -> StrictMaybe DijkstraGenesis)
-> NodeConfiguration
-> DijkstraGenesis
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeConfiguration -> StrictMaybe DijkstraGenesis
Cfg.experimentalGenesisConfig

-- | Whether the configuration admits the experimental era.
experimentalErasEnabled :: Cfg.NodeConfiguration -> Bool
experimentalErasEnabled :: NodeConfiguration -> Bool
experimentalErasEnabled =
  Identity Bool -> Bool
forall a. Identity a -> a
runIdentity (Identity Bool -> Bool)
-> (NodeConfiguration -> Identity Bool)
-> NodeConfiguration
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestingConfiguration Identity -> Identity Bool
forall (f :: * -> *). TestingConfiguration f -> f Bool
Cfg.experimentalHardForksEnabled (TestingConfiguration Identity -> Identity Bool)
-> (NodeConfiguration -> TestingConfiguration Identity)
-> NodeConfiguration
-> Identity Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeConfiguration -> TestingConfiguration Identity
Cfg.testingConfiguration

-- | Inherited from cardano-node's @Cardano.Node.Protocol.Dijkstra@, by way of
-- the copy of that module these tools used to vendor. The fields that
-- @cardano-ledger@ added later, which cardano-node does not set, take the values
-- of the ledger's example Dijkstra genesis (@Test.Cardano.Ledger.Dijkstra.Examples@),
-- which the Leios fields below already match.
defaultDijkstraGenesis :: SL.DijkstraGenesis
defaultDijkstraGenesis :: DijkstraGenesis
defaultDijkstraGenesis =
  let upgradePParamsDef :: UpgradeDijkstraPParams Identity era
upgradePParamsDef =
        UpgradeDijkstraPParams
          { udppMaxRefScriptSizePerBlock :: HKD Identity Word32
udppMaxRefScriptSizePerBlock = HKD Identity Word32
1048576
          , udppMaxRefScriptSizePerTx :: HKD Identity Word32
udppMaxRefScriptSizePerTx = HKD Identity Word32
204800
          , udppRefScriptCostStride :: HKD Identity (NonZero Word32)
udppRefScriptCostStride = Word32 -> NonZero Word32
forall a. a -> NonZero a
unsafeNonZero Word32
25600
          , udppRefScriptCostMultiplier :: HKD Identity PositiveInterval
udppRefScriptCostMultiplier = HKD Identity PositiveInterval
-> Maybe (HKD Identity PositiveInterval)
-> HKD Identity PositiveInterval
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> HKD Identity PositiveInterval
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible") (Maybe (HKD Identity PositiveInterval)
 -> HKD Identity PositiveInterval)
-> Maybe (HKD Identity PositiveInterval)
-> HKD Identity PositiveInterval
forall a b. (a -> b) -> a -> b
$ Ratio Integer -> Maybe (HKD Identity PositiveInterval)
forall r. BoundedRational r => Ratio Integer -> Maybe r
boundRational Ratio Integer
1.2
          , udppMaxPledgeLeverage :: HKD Identity MaxPledgeLeverage
udppMaxPledgeLeverage = StrictMaybe NonNegativeInterval -> MaxPledgeLeverage
MaxPledgeLeverage StrictMaybe NonNegativeInterval
forall a. StrictMaybe a
SNothing
          , udppMinPoolMargin :: HKD Identity UnitInterval
udppMinPoolMargin = HKD Identity UnitInterval
-> Maybe (HKD Identity UnitInterval) -> HKD Identity UnitInterval
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> HKD Identity UnitInterval
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible") (Maybe (HKD Identity UnitInterval) -> HKD Identity UnitInterval)
-> Maybe (HKD Identity UnitInterval) -> HKD Identity UnitInterval
forall a b. (a -> b) -> a -> b
$ Ratio Integer -> Maybe (HKD Identity UnitInterval)
forall r. BoundedRational r => Ratio Integer -> Maybe r
boundRational Ratio Integer
0.015
          , udppPlutusV4CostModel :: HKD Identity CostModel
udppPlutusV4CostModel =
              CostModel -> Either CostModelApplyError CostModel -> CostModel
forall b a. b -> Either a b -> b
fromRight ([Char] -> CostModel
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible") (Either CostModelApplyError CostModel -> CostModel)
-> Either CostModelApplyError CostModel -> CostModel
forall a b. (a -> b) -> a -> b
$
                Language -> [Int64] -> Either CostModelApplyError CostModel
mkCostModel Language
PlutusV4 (Int -> Int64 -> [Int64]
forall a. Int -> a -> [a]
replicate (Language -> Int
costModelInitParamCount Language
PlutusV4) Int64
0)
          , udppLeiosAnnouncementPeriodLength :: HKD Identity Milliseconds32
udppLeiosAnnouncementPeriodLength = Word32 -> Milliseconds32
Milliseconds32 Word32
1_000
          , udppLeiosVotePeriodLength :: HKD Identity Milliseconds32
udppLeiosVotePeriodLength = Word32 -> Milliseconds32
Milliseconds32 Word32
4_000
          , udppLeiosDiffusionPeriodLength :: HKD Identity Milliseconds32
udppLeiosDiffusionPeriodLength = Word32 -> Milliseconds32
Milliseconds32 Word32
7_000
          , udppLeiosCommitteeSize :: HKD Identity Word16
udppLeiosCommitteeSize = Word16
900 :: Word16
          , udppLeiosQuorumStakeThreshold :: HKD Identity UnitInterval
udppLeiosQuorumStakeThreshold = HKD Identity UnitInterval
-> Maybe (HKD Identity UnitInterval) -> HKD Identity UnitInterval
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> HKD Identity UnitInterval
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible") (Maybe (HKD Identity UnitInterval) -> HKD Identity UnitInterval)
-> Maybe (HKD Identity UnitInterval) -> HKD Identity UnitInterval
forall a b. (a -> b) -> a -> b
$ Ratio Integer -> Maybe (HKD Identity UnitInterval)
forall r. BoundedRational r => Ratio Integer -> Maybe r
boundRational Ratio Integer
0.75
          , udppMaxEndorserBlockReferencesSize :: HKD Identity Word32
udppMaxEndorserBlockReferencesSize = HKD Identity Word32
512 HKD Identity Word32 -> HKD Identity Word32 -> HKD Identity Word32
forall a. Num a => a -> a -> a
* HKD Identity Word32
1024
          , udppMaxEndorserBlockTxsSize :: HKD Identity Word32
udppMaxEndorserBlockTxsSize = HKD Identity Word32
12 HKD Identity Word32 -> HKD Identity Word32 -> HKD Identity Word32
forall a. Num a => a -> a -> a
* HKD Identity Word32
1024 HKD Identity Word32 -> HKD Identity Word32 -> HKD Identity Word32
forall a. Num a => a -> a -> a
* HKD Identity Word32
1024
          , udppMaxEndorserBlockExUnits :: HKD Identity OrdExUnits
udppMaxEndorserBlockExUnits = ExUnits -> OrdExUnits
OrdExUnits (ExUnits -> OrdExUnits) -> ExUnits -> OrdExUnits
forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> ExUnits
ExUnits Natural
7_000_000_000 Natural
2_000_000_000_000
          , udppMaxRefScriptSizePerEndorserBlock :: HKD Identity Word32
udppMaxRefScriptSizePerEndorserBlock = HKD Identity Word32
12 HKD Identity Word32 -> HKD Identity Word32 -> HKD Identity Word32
forall a. Num a => a -> a -> a
* HKD Identity Word32
1024 HKD Identity Word32 -> HKD Identity Word32 -> HKD Identity Word32
forall a. Num a => a -> a -> a
* HKD Identity Word32
1024
          , udppPerasMinCandidateBlockAge :: HKD Identity SlotInterval
udppPerasMinCandidateBlockAge = Word32 -> SlotInterval
SlotInterval Word32
90
          , udppPerasHealingFactor :: HKD Identity PositiveInterval
udppPerasHealingFactor = HKD Identity PositiveInterval
-> Maybe (HKD Identity PositiveInterval)
-> HKD Identity PositiveInterval
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> HKD Identity PositiveInterval
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible") (Maybe (HKD Identity PositiveInterval)
 -> HKD Identity PositiveInterval)
-> Maybe (HKD Identity PositiveInterval)
-> HKD Identity PositiveInterval
forall a b. (a -> b) -> a -> b
$ Ratio Integer -> Maybe (HKD Identity PositiveInterval)
forall r. BoundedRational r => Ratio Integer -> Maybe r
boundRational Ratio Integer
0.5
          , udppPerasCertBoost :: HKD Identity Word16
udppPerasCertBoost = Word16
HKD Identity Word16
15
          , udppPerasTargetCommitteeSize :: HKD Identity Word16
udppPerasTargetCommitteeSize = Word16
HKD Identity Word16
800
          , udppPerasBootstrapRound :: HKD Identity (StrictMaybe Word32)
udppPerasBootstrapRound = Word32 -> StrictMaybe Word32
forall a. a -> StrictMaybe a
SJust Word32
0
          , udppPerasQuorumThresholdSafetyMargin :: HKD Identity UnitInterval
udppPerasQuorumThresholdSafetyMargin = HKD Identity UnitInterval
-> Maybe (HKD Identity UnitInterval) -> HKD Identity UnitInterval
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> HKD Identity UnitInterval
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible") (Maybe (HKD Identity UnitInterval) -> HKD Identity UnitInterval)
-> Maybe (HKD Identity UnitInterval) -> HKD Identity UnitInterval
forall a b. (a -> b) -> a -> b
$ Ratio Integer -> Maybe (HKD Identity UnitInterval)
forall r. BoundedRational r => Ratio Integer -> Maybe r
boundRational Ratio Integer
0.05
          , -- No pricing logic uses these yet; a later intra-era hard fork within
            -- the Dijkstra era enables them.
            udppRefInputsCostPerMultiAssetPolicy :: HKD Identity Coin
udppRefInputsCostPerMultiAssetPolicy = Integer -> Coin
Coin Integer
0
          , udppRefInputsCostPerDatumByte :: HKD Identity CoinPerByte
udppRefInputsCostPerDatumByte = CompactForm Coin -> CoinPerByte
CoinPerByte (Word64 -> CompactForm Coin
CompactCoin Word64
0)
          }
   in SL.DijkstraGenesis{dgUpgradePParams :: UpgradeDijkstraPParams Identity LatestKnownEra
SL.dgUpgradePParams = UpgradeDijkstraPParams Identity LatestKnownEra
forall {era}. UpgradeDijkstraPParams Identity era
upgradePParamsDef}

-- | Build the 'CardanoHardForkTriggers' from the @Testing@ section of the
-- configuration: each era hard-forks at its configured epoch, or at the
-- default protocol version when no epoch is given.
--
-- If an era is configured to hard-fork at a specific epoch, then so must all
-- earlier eras; otherwise the configuration is rejected.
mkHardForkTriggers ::
  Cfg.TestingConfiguration Identity -> Either String CardanoHardForkTriggers
mkHardForkTriggers :: TestingConfiguration Identity
-> Either [Char] CardanoHardForkTriggers
mkHardForkTriggers TestingConfiguration Identity
testCfg
  | ((Maybe Word64, Maybe Word64) -> Bool)
-> [(Maybe Word64, Maybe Word64)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Maybe Word64
earlier, Maybe Word64
later) -> Maybe Word64 -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Word64
earlier Bool -> Bool -> Bool
&& Maybe Word64 -> Bool
forall a. Maybe a -> Bool
isJust Maybe Word64
later) ([Maybe Word64] -> [Maybe Word64] -> [(Maybe Word64, Maybe Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe Word64]
epochs (Int -> [Maybe Word64] -> [Maybe Word64]
forall a. Int -> [a] -> [a]
drop Int
1 [Maybe Word64]
epochs)) =
      [Char] -> Either [Char] CardanoHardForkTriggers
forall a b. a -> Either a b
Left
        [Char]
"if the Cardano config file sets a Test*HardForkAtEpoch, it must also set it for all previous eras."
  | Bool
otherwise =
      CardanoHardForkTriggers -> Either [Char] CardanoHardForkTriggers
forall a b. b -> Either a b
Right
        CardanoHardForkTriggers'
          { triggerHardForkShelley :: CardanoHardForkTrigger
  (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)
triggerHardForkShelley = Maybe Word64
-> CardanoHardForkTrigger
     (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)
forall blk. Maybe Word64 -> CardanoHardForkTrigger blk
toTrigger ((TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
forall (f :: * -> *). TestingConfiguration f -> StrictMaybe Word64
Cfg.testShelleyHardForkAtEpoch)
          , triggerHardForkAllegra :: CardanoHardForkTrigger
  (ShelleyBlock (TPraos StandardCrypto) AllegraEra)
triggerHardForkAllegra = Maybe Word64
-> CardanoHardForkTrigger
     (ShelleyBlock (TPraos StandardCrypto) AllegraEra)
forall blk. Maybe Word64 -> CardanoHardForkTrigger blk
toTrigger ((TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
forall (f :: * -> *). TestingConfiguration f -> StrictMaybe Word64
Cfg.testAllegraHardForkAtEpoch)
          , triggerHardForkMary :: CardanoHardForkTrigger
  (ShelleyBlock (TPraos StandardCrypto) MaryEra)
triggerHardForkMary = Maybe Word64
-> CardanoHardForkTrigger
     (ShelleyBlock (TPraos StandardCrypto) MaryEra)
forall blk. Maybe Word64 -> CardanoHardForkTrigger blk
toTrigger ((TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
forall (f :: * -> *). TestingConfiguration f -> StrictMaybe Word64
Cfg.testMaryHardForkAtEpoch)
          , triggerHardForkAlonzo :: CardanoHardForkTrigger
  (ShelleyBlock (TPraos StandardCrypto) AlonzoEra)
triggerHardForkAlonzo = Maybe Word64
-> CardanoHardForkTrigger
     (ShelleyBlock (TPraos StandardCrypto) AlonzoEra)
forall blk. Maybe Word64 -> CardanoHardForkTrigger blk
toTrigger ((TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
forall (f :: * -> *). TestingConfiguration f -> StrictMaybe Word64
Cfg.testAlonzoHardForkAtEpoch)
          , triggerHardForkBabbage :: CardanoHardForkTrigger
  (ShelleyBlock (Praos StandardCrypto) BabbageEra)
triggerHardForkBabbage = Maybe Word64
-> CardanoHardForkTrigger
     (ShelleyBlock (Praos StandardCrypto) BabbageEra)
forall blk. Maybe Word64 -> CardanoHardForkTrigger blk
toTrigger ((TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
forall (f :: * -> *). TestingConfiguration f -> StrictMaybe Word64
Cfg.testBabbageHardForkAtEpoch)
          , triggerHardForkConway :: CardanoHardForkTrigger
  (ShelleyBlock (Praos StandardCrypto) ConwayEra)
triggerHardForkConway = Maybe Word64
-> CardanoHardForkTrigger
     (ShelleyBlock (Praos StandardCrypto) ConwayEra)
forall blk. Maybe Word64 -> CardanoHardForkTrigger blk
toTrigger ((TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
forall (f :: * -> *). TestingConfiguration f -> StrictMaybe Word64
Cfg.testConwayHardForkAtEpoch)
          , triggerHardForkDijkstra :: CardanoHardForkTrigger
  (ShelleyBlock (Praos2 StandardCrypto) LatestKnownEra)
triggerHardForkDijkstra = Maybe Word64
-> CardanoHardForkTrigger
     (ShelleyBlock (Praos2 StandardCrypto) LatestKnownEra)
forall blk. Maybe Word64 -> CardanoHardForkTrigger blk
toTrigger ((TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
forall (f :: * -> *). TestingConfiguration f -> StrictMaybe Word64
Cfg.testDijkstraHardForkAtEpoch)
          }
 where
  -- cardano-config records the configured epochs as 'StrictMaybe'; the tools
  -- work with plain 'Maybe' here.
  epochOf ::
    (Cfg.TestingConfiguration Identity -> StrictMaybe Word64) -> Maybe Word64
  epochOf :: (TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
f = StrictMaybe Word64 -> Maybe Word64
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe (TestingConfiguration Identity -> StrictMaybe Word64
f TestingConfiguration Identity
testCfg)

  -- In Shelley-era order; mirrors the field order of 'CardanoHardForkTriggers''.
  epochs :: [Maybe Word64]
epochs =
    [ (TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
forall (f :: * -> *). TestingConfiguration f -> StrictMaybe Word64
Cfg.testShelleyHardForkAtEpoch
    , (TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
forall (f :: * -> *). TestingConfiguration f -> StrictMaybe Word64
Cfg.testAllegraHardForkAtEpoch
    , (TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
forall (f :: * -> *). TestingConfiguration f -> StrictMaybe Word64
Cfg.testMaryHardForkAtEpoch
    , (TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
forall (f :: * -> *). TestingConfiguration f -> StrictMaybe Word64
Cfg.testAlonzoHardForkAtEpoch
    , (TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
forall (f :: * -> *). TestingConfiguration f -> StrictMaybe Word64
Cfg.testBabbageHardForkAtEpoch
    , (TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
forall (f :: * -> *). TestingConfiguration f -> StrictMaybe Word64
Cfg.testConwayHardForkAtEpoch
    , (TestingConfiguration Identity -> StrictMaybe Word64)
-> Maybe Word64
epochOf TestingConfiguration Identity -> StrictMaybe Word64
forall (f :: * -> *). TestingConfiguration f -> StrictMaybe Word64
Cfg.testDijkstraHardForkAtEpoch
    ]

  toTrigger :: Maybe Word64 -> CardanoHardForkTrigger blk
  toTrigger :: forall blk. Maybe Word64 -> CardanoHardForkTrigger blk
toTrigger =
    CardanoHardForkTrigger blk
-> (Word64 -> CardanoHardForkTrigger blk)
-> Maybe Word64
-> CardanoHardForkTrigger blk
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      CardanoHardForkTrigger blk
forall blk. CardanoHardForkTrigger blk
CardanoTriggerHardForkAtDefaultVersion
      (EpochNo -> CardanoHardForkTrigger blk
forall blk. EpochNo -> CardanoHardForkTrigger blk
CardanoTriggerHardForkAtEpoch (EpochNo -> CardanoHardForkTrigger blk)
-> (Word64 -> EpochNo) -> Word64 -> CardanoHardForkTrigger blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> EpochNo
EpochNo)