{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

{- HLINT ignore "Redundant fmap" -}

module Cardano.Api.LedgerState
  ( -- * Initialization / Accumulation
    envSecurityParam
  , LedgerState
    ( ..
    , LedgerStateByron
    , LedgerStateShelley
    , LedgerStateAllegra
    , LedgerStateMary
    , LedgerStateAlonzo
    , LedgerStateBabbage
    , LedgerStateConway
    )
  , encodeLedgerState
  , decodeLedgerState
  , initialLedgerState
  , applyBlock
  , ValidationMode (..)
  , applyBlockWithEvents
  , AnyNewEpochState (..)
  , getAnyNewEpochState

    -- * Traversing the block chain
  , foldBlocks
  , FoldStatus (..)
  , chainSyncClientWithLedgerState
  , chainSyncClientPipelinedWithLedgerState

    -- * Ledger state conditions
  , ConditionResult (..)
  , fromConditionResult
  , toConditionResult
  , foldEpochState

    -- * Errors
  , LedgerStateError (..)
  , FoldBlocksError (..)
  , GenesisConfigError (..)
  , InitialLedgerStateError (..)

    -- * Leadership schedule
  , LeadershipError (..)
  , constructGlobals
  , currentEpochEligibleLeadershipSlots
  , nextEpochEligibleLeadershipSlots

    -- * Node Config
  , NodeConfig (..)

    -- ** Network Config
  , NodeConfigFile
  , readNodeConfig

    -- ** Genesis Config
  , GenesisConfig (..)
  , readCardanoGenesisConfig
  , mkProtocolInfoCardano

    -- *** Byron Genesis Config
  , readByronGenesisConfig

    -- *** Shelley Genesis Config
  , ShelleyConfig (..)
  , GenesisHashShelley (..)
  , readShelleyGenesisConfig
  , shelleyPraosNonce

    -- *** Alonzo Genesis Config
  , GenesisHashAlonzo (..)
  , readAlonzoGenesisConfig

    -- *** Conway Genesis Config
  , GenesisHashConway (..)
  , readConwayGenesisConfig

    -- ** Environment
  , Env (..)
  , genesisConfigToEnv
  )
where

import           Cardano.Api.Block
import           Cardano.Api.Certificate
import           Cardano.Api.Eon.ShelleyBasedEra
import           Cardano.Api.Eras.Case
import           Cardano.Api.Eras.Core (CardanoEra, forEraMaybeEon)
import           Cardano.Api.Error as Api
import           Cardano.Api.Genesis
import           Cardano.Api.IO
import           Cardano.Api.IPC (ConsensusModeParams (..),
                   LocalChainSyncClient (LocalChainSyncClientPipelined),
                   LocalNodeClientProtocols (..), LocalNodeClientProtocolsInMode,
                   LocalNodeConnectInfo (..), connectToLocalNode)
import           Cardano.Api.Keys.Praos
import           Cardano.Api.LedgerEvents.ConvertLedgerEvent
import           Cardano.Api.LedgerEvents.LedgerEvent
import           Cardano.Api.Modes (EpochSlots (..))
import qualified Cardano.Api.Modes as Api
import           Cardano.Api.Monad.Error
import           Cardano.Api.NetworkId (NetworkId (..), NetworkMagic (NetworkMagic))
import           Cardano.Api.Pretty
import           Cardano.Api.Query (CurrentEpochState (..), PoolDistribution (unPoolDistr),
                   ProtocolState, SerialisedCurrentEpochState (..), SerialisedPoolDistribution,
                   decodeCurrentEpochState, decodePoolDistribution, decodeProtocolState)
import qualified Cardano.Api.ReexposeLedger as Ledger
import           Cardano.Api.SpecialByron as Byron
import           Cardano.Api.Utils (textShow)

import qualified Cardano.Binary as CBOR
import qualified Cardano.Chain.Genesis
import qualified Cardano.Chain.Update
import           Cardano.Crypto (ProtocolMagicId (unProtocolMagicId), RequiresNetworkMagic (..))
import qualified Cardano.Crypto.Hash.Blake2b
import qualified Cardano.Crypto.Hash.Class
import qualified Cardano.Crypto.Hashing
import qualified Cardano.Crypto.ProtocolMagic
import qualified Cardano.Crypto.VRF as Crypto
import qualified Cardano.Crypto.VRF.Class as VRF
import           Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..))
import qualified Cardano.Ledger.Api.Era as Ledger
import qualified Cardano.Ledger.Api.Transition as Ledger
import           Cardano.Ledger.BaseTypes (Globals (..), Nonce, ProtVer (..), natVersion, (⭒))
import qualified Cardano.Ledger.BaseTypes as Ledger
import qualified Cardano.Ledger.BHeaderView as Ledger
import           Cardano.Ledger.Binary (DecoderError)
import qualified Cardano.Ledger.Coin as SL
import           Cardano.Ledger.Conway.Genesis (ConwayGenesis (..))
import qualified Cardano.Ledger.Keys as SL
import qualified Cardano.Ledger.PoolDistr as SL
import qualified Cardano.Ledger.Shelley.API as ShelleyAPI
import qualified Cardano.Ledger.Shelley.Core as Core
import qualified Cardano.Ledger.Shelley.Genesis as Ledger
import qualified Cardano.Protocol.TPraos.API as TPraos
import           Cardano.Protocol.TPraos.BHeader (checkLeaderNatValue)
import qualified Cardano.Protocol.TPraos.BHeader as TPraos
import           Cardano.Slotting.EpochInfo (EpochInfo)
import qualified Cardano.Slotting.EpochInfo.API as Slot
import           Cardano.Slotting.Slot (WithOrigin (At, Origin))
import qualified Cardano.Slotting.Slot as Slot
import qualified Ouroboros.Consensus.Block.Abstract as Consensus
import           Ouroboros.Consensus.Block.Forging (BlockForging)
import qualified Ouroboros.Consensus.Byron.Ledger as Byron
import qualified Ouroboros.Consensus.Cardano as Consensus
import qualified Ouroboros.Consensus.Cardano.Block as Consensus
import qualified Ouroboros.Consensus.Cardano.CanHardFork as Consensus
import qualified Ouroboros.Consensus.Cardano.Node as Consensus
import qualified Ouroboros.Consensus.Config as Consensus
import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus
import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as HFC
import qualified Ouroboros.Consensus.HardFork.Combinator.Basics as HFC
import qualified Ouroboros.Consensus.Ledger.Abstract as Ledger
import qualified Ouroboros.Consensus.Ledger.Extended as Ledger
import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus
import           Ouroboros.Consensus.Protocol.Abstract (ChainDepState, ConsensusProtocol (..))
import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus
import           Ouroboros.Consensus.Protocol.Praos.VRF (mkInputVRF, vrfLeaderValue)
import qualified Ouroboros.Consensus.Shelley.HFEras as Shelley
import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Shelley
import qualified Ouroboros.Consensus.Shelley.Ledger.Query.Types as Consensus
import           Ouroboros.Consensus.Storage.Serialisation
import           Ouroboros.Consensus.TypeFamilyWrappers (WrapLedgerEvent (WrapLedgerEvent))
import           Ouroboros.Network.Block (blockNo)
import qualified Ouroboros.Network.Block
import           Ouroboros.Network.Mux (MuxError)
import qualified Ouroboros.Network.Protocol.ChainSync.Client as CS
import qualified Ouroboros.Network.Protocol.ChainSync.ClientPipelined as CSP
import           Ouroboros.Network.Protocol.ChainSync.PipelineDecision

import           Control.Concurrent
import           Control.DeepSeq
import           Control.Error.Util (note)
import           Control.Exception.Safe
import           Control.Monad
import           Control.Monad.State.Strict
import           Data.Aeson as Aeson (FromJSON (parseJSON), Object, eitherDecodeStrict', withObject,
                   (.:), (.:?))
import           Data.Aeson.Types (Parser)
import           Data.Bifunctor
import           Data.ByteArray (ByteArrayAccess)
import qualified Data.ByteArray
import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Lazy as LBS
import           Data.ByteString.Short as BSS
import           Data.Foldable (asum)
import           Data.IORef
import qualified Data.List as List
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe
import           Data.Proxy (Proxy (Proxy))
import           Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.SOP.Strict.NP
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as LT
import           Data.Text.Lazy.Builder (toLazyText)
import           Data.Word
import qualified Data.Yaml as Yaml
import           Formatting.Buildable (build)
import           GHC.Exts (IsList (..))
import           Lens.Micro
import           Network.TypedProtocol.Pipelined (Nat (..))
import           System.FilePath

data InitialLedgerStateError
  = -- | Failed to read or parse the network config file.
    ILSEConfigFile Text
  | -- | Failed to read or parse a genesis file linked from the network config file.
    ILSEGenesisFile GenesisConfigError
  | -- | Failed to derive the Ledger or Consensus config.
    ILSELedgerConsensusConfig GenesisConfigError
  deriving Int -> InitialLedgerStateError -> ShowS
[InitialLedgerStateError] -> ShowS
InitialLedgerStateError -> String
(Int -> InitialLedgerStateError -> ShowS)
-> (InitialLedgerStateError -> String)
-> ([InitialLedgerStateError] -> ShowS)
-> Show InitialLedgerStateError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InitialLedgerStateError -> ShowS
showsPrec :: Int -> InitialLedgerStateError -> ShowS
$cshow :: InitialLedgerStateError -> String
show :: InitialLedgerStateError -> String
$cshowList :: [InitialLedgerStateError] -> ShowS
showList :: [InitialLedgerStateError] -> ShowS
Show

instance Exception InitialLedgerStateError

instance Error InitialLedgerStateError where
  prettyError :: forall ann. InitialLedgerStateError -> Doc ann
prettyError = \case
    ILSEConfigFile Text
err ->
      Doc ann
"Failed to read or parse the network config file:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
err
    ILSEGenesisFile GenesisConfigError
err ->
      Doc ann
"Failed to read or parse a genesis file linked from the network config file:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> GenesisConfigError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. GenesisConfigError -> Doc ann
prettyError GenesisConfigError
err
    ILSELedgerConsensusConfig GenesisConfigError
err ->
      Doc ann
"Failed to derive the Ledger or Consensus config:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> GenesisConfigError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. GenesisConfigError -> Doc ann
prettyError GenesisConfigError
err

data LedgerStateError
  = -- | When using QuickValidation, the block hash did not match the expected
    -- block hash after applying a new block to the current ledger state.
    ApplyBlockHashMismatch Text
  | -- | When using FullValidation, an error occurred when applying a new block
    -- to the current ledger state.
    ApplyBlockError (Consensus.CardanoLedgerError Consensus.StandardCrypto)
  | -- | Encountered a rollback larger than the security parameter.
    InvalidRollback
      SlotNo
      -- ^ Oldest known slot number that we can roll back to.
      ChainPoint
      -- ^ Rollback was attempted to this point.
  | -- | The ledger state condition you were interested in was not met
    -- prior to the termination epoch.
    TerminationEpochReached EpochNo
  | UnexpectedLedgerState
      AnyShelleyBasedEra
      -- ^ Expected era
      (Consensus.CardanoLedgerState Consensus.StandardCrypto)
      -- ^ Ledgerstate from an unexpected era
  | ByronEraUnsupported
  | DebugError !String
  deriving Int -> LedgerStateError -> ShowS
[LedgerStateError] -> ShowS
LedgerStateError -> String
(Int -> LedgerStateError -> ShowS)
-> (LedgerStateError -> String)
-> ([LedgerStateError] -> ShowS)
-> Show LedgerStateError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LedgerStateError -> ShowS
showsPrec :: Int -> LedgerStateError -> ShowS
$cshow :: LedgerStateError -> String
show :: LedgerStateError -> String
$cshowList :: [LedgerStateError] -> ShowS
showList :: [LedgerStateError] -> ShowS
Show

instance Exception LedgerStateError

instance Error LedgerStateError where
  prettyError :: forall ann. LedgerStateError -> Doc ann
prettyError = \case
    DebugError String
e -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
e
    ApplyBlockHashMismatch Text
err -> Doc ann
"Applying a block did not result in the expected block hash:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
err
    ApplyBlockError CardanoLedgerError StandardCrypto
hardForkLedgerError -> Doc ann
"Applying a block resulted in an error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CardanoLedgerError StandardCrypto -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow CardanoLedgerError StandardCrypto
hardForkLedgerError
    InvalidRollback SlotNo
oldestSupported ChainPoint
rollbackPoint ->
      Doc ann
"Encountered a rollback larger than the security parameter. Attempted to roll back to"
        Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ChainPoint -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow ChainPoint
rollbackPoint
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
", but oldest supported slot is"
          Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> SlotNo -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow SlotNo
oldestSupported
    TerminationEpochReached EpochNo
epochNo ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
        [ Doc ann
"The ledger state condition you were interested in was not met "
        , Doc ann
"prior to the termination epoch:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> EpochNo -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow EpochNo
epochNo
        ]
    UnexpectedLedgerState AnyShelleyBasedEra
expectedEra CardanoLedgerState StandardCrypto
unexpectedLS ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
        [ Doc ann
"Expected ledger state from the "
        , AnyShelleyBasedEra -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow AnyShelleyBasedEra
expectedEra
        , Doc ann
" era, but got "
        , CardanoLedgerState StandardCrypto -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow CardanoLedgerState StandardCrypto
unexpectedLS
        ]
    LedgerStateError
ByronEraUnsupported -> Doc ann
"Byron era is not supported"

-- | Get the environment and initial ledger state.
initialLedgerState
  :: MonadIOTransError InitialLedgerStateError t m
  => NodeConfigFile 'In
  -- ^ Path to the cardano-node config file (e.g. <path to cardano-node project>/configuration/cardano/mainnet-config.json)
  -> t m (Env, LedgerState)
  -- ^ The environment and initial ledger state
initialLedgerState :: forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError InitialLedgerStateError t m =>
NodeConfigFile 'In -> t m (Env, LedgerState)
initialLedgerState NodeConfigFile 'In
nodeConfigFile = do
  -- TODO Once support for querying the ledger config is added to the node, we
  -- can remove the nodeConfigFile argument and much of the code in this
  -- module.
  NodeConfig
config <- (Text -> InitialLedgerStateError)
-> ExceptT Text m NodeConfig -> t m NodeConfig
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError Text -> InitialLedgerStateError
ILSEConfigFile (NodeConfigFile 'In -> ExceptT Text m NodeConfig
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
NodeConfigFile 'In -> m NodeConfig
readNodeConfig NodeConfigFile 'In
nodeConfigFile)
  GenesisConfig
genesisConfig <- (GenesisConfigError -> InitialLedgerStateError)
-> ExceptT GenesisConfigError m GenesisConfig -> t m GenesisConfig
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError GenesisConfigError -> InitialLedgerStateError
ILSEGenesisFile (Maybe (CardanoEra Any)
-> NodeConfig -> ExceptT GenesisConfigError m GenesisConfig
forall (t :: (* -> *) -> * -> *) (m :: * -> *) era.
MonadIOTransError GenesisConfigError t m =>
Maybe (CardanoEra era) -> NodeConfig -> t m GenesisConfig
readCardanoGenesisConfig Maybe (CardanoEra Any)
forall a. Maybe a
Nothing NodeConfig
config)
  Env
env <- (GenesisConfigError -> InitialLedgerStateError)
-> ExceptT GenesisConfigError m Env -> t m Env
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError GenesisConfigError -> InitialLedgerStateError
ILSELedgerConsensusConfig (Either GenesisConfigError Env -> ExceptT GenesisConfigError m Env
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (GenesisConfig -> Either GenesisConfigError Env
genesisConfigToEnv GenesisConfig
genesisConfig))
  let ledgerState :: LedgerState
ledgerState = GenesisConfig -> LedgerState
initLedgerStateVar GenesisConfig
genesisConfig
  (Env, LedgerState) -> t m (Env, LedgerState)
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Env
env, LedgerState
ledgerState)

-- | Apply a single block to the current ledger state.
applyBlock
  :: Env
  -- ^ The environment returned by @initialLedgerState@
  -> LedgerState
  -- ^ The current ledger state
  -> ValidationMode
  -> BlockInMode
  -- ^ Some block to apply
  -> Either LedgerStateError (LedgerState, [LedgerEvent])
  -- ^ The new ledger state (or an error).
applyBlock :: Env
-> LedgerState
-> ValidationMode
-> BlockInMode
-> Either LedgerStateError LedgerStateEvents
applyBlock Env
env LedgerState
oldState ValidationMode
validationMode =
  Env
-> LedgerState
-> ValidationMode
-> CardanoBlock StandardCrypto
-> Either LedgerStateError LedgerStateEvents
applyBlock' Env
env LedgerState
oldState ValidationMode
validationMode (CardanoBlock StandardCrypto
 -> Either LedgerStateError LedgerStateEvents)
-> (BlockInMode -> CardanoBlock StandardCrypto)
-> BlockInMode
-> Either LedgerStateError LedgerStateEvents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockInMode -> CardanoBlock StandardCrypto
forall block.
(CardanoBlock StandardCrypto ~ block) =>
BlockInMode -> block
toConsensusBlock

pattern LedgerStateByron
  :: Ledger.LedgerState Byron.ByronBlock
  -> LedgerState
pattern $mLedgerStateByron :: forall {r}.
LedgerState -> (LedgerState ByronBlock -> r) -> ((# #) -> r) -> r
LedgerStateByron st <- LedgerState (Consensus.LedgerStateByron st)

pattern LedgerStateShelley
  :: Ledger.LedgerState Shelley.StandardShelleyBlock
  -> LedgerState
pattern $mLedgerStateShelley :: forall {r}.
LedgerState
-> (LedgerState
      (ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto))
    -> r)
-> ((# #) -> r)
-> r
LedgerStateShelley st <- LedgerState (Consensus.LedgerStateShelley st)

pattern LedgerStateAllegra
  :: Ledger.LedgerState Shelley.StandardAllegraBlock
  -> LedgerState
pattern $mLedgerStateAllegra :: forall {r}.
LedgerState
-> (LedgerState
      (ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto))
    -> r)
-> ((# #) -> r)
-> r
LedgerStateAllegra st <- LedgerState (Consensus.LedgerStateAllegra st)

pattern LedgerStateMary
  :: Ledger.LedgerState Shelley.StandardMaryBlock
  -> LedgerState
pattern $mLedgerStateMary :: forall {r}.
LedgerState
-> (LedgerState
      (ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto))
    -> r)
-> ((# #) -> r)
-> r
LedgerStateMary st <- LedgerState (Consensus.LedgerStateMary st)

pattern LedgerStateAlonzo
  :: Ledger.LedgerState Shelley.StandardAlonzoBlock
  -> LedgerState
pattern $mLedgerStateAlonzo :: forall {r}.
LedgerState
-> (LedgerState
      (ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto))
    -> r)
-> ((# #) -> r)
-> r
LedgerStateAlonzo st <- LedgerState (Consensus.LedgerStateAlonzo st)

pattern LedgerStateBabbage
  :: Ledger.LedgerState Shelley.StandardBabbageBlock
  -> LedgerState
pattern $mLedgerStateBabbage :: forall {r}.
LedgerState
-> (LedgerState
      (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
    -> r)
-> ((# #) -> r)
-> r
LedgerStateBabbage st <- LedgerState (Consensus.LedgerStateBabbage st)

pattern LedgerStateConway
  :: Ledger.LedgerState Shelley.StandardConwayBlock
  -> LedgerState
pattern $mLedgerStateConway :: forall {r}.
LedgerState
-> (LedgerState
      (ShelleyBlock
         (Praos StandardCrypto) (LatestKnownEra StandardCrypto))
    -> r)
-> ((# #) -> r)
-> r
LedgerStateConway st <- LedgerState (Consensus.LedgerStateConway st)

{-# COMPLETE
  LedgerStateByron
  , LedgerStateShelley
  , LedgerStateAllegra
  , LedgerStateMary
  , LedgerStateAlonzo
  , LedgerStateBabbage
  , LedgerStateConway
  #-}

data FoldBlocksError
  = FoldBlocksInitialLedgerStateError !InitialLedgerStateError
  | FoldBlocksApplyBlockError !LedgerStateError
  | FoldBlocksIOException !IOException
  | FoldBlocksMuxError !MuxError
  deriving Int -> FoldBlocksError -> ShowS
[FoldBlocksError] -> ShowS
FoldBlocksError -> String
(Int -> FoldBlocksError -> ShowS)
-> (FoldBlocksError -> String)
-> ([FoldBlocksError] -> ShowS)
-> Show FoldBlocksError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FoldBlocksError -> ShowS
showsPrec :: Int -> FoldBlocksError -> ShowS
$cshow :: FoldBlocksError -> String
show :: FoldBlocksError -> String
$cshowList :: [FoldBlocksError] -> ShowS
showList :: [FoldBlocksError] -> ShowS
Show

instance Error FoldBlocksError where
  prettyError :: forall ann. FoldBlocksError -> Doc ann
prettyError = \case
    FoldBlocksInitialLedgerStateError InitialLedgerStateError
err -> InitialLedgerStateError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. InitialLedgerStateError -> Doc ann
prettyError InitialLedgerStateError
err
    FoldBlocksApplyBlockError LedgerStateError
err -> Doc ann
"Failed when applying a block:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> LedgerStateError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. LedgerStateError -> Doc ann
prettyError LedgerStateError
err
    FoldBlocksIOException IOException
err -> Doc ann
"IOException:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> IOException -> Doc ann
forall a ann. Exception a => a -> Doc ann
prettyException IOException
err
    FoldBlocksMuxError MuxError
err -> Doc ann
"FoldBlocks error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> MuxError -> Doc ann
forall a ann. Exception a => a -> Doc ann
prettyException MuxError
err

-- | Type that lets us decide whether to continue or stop
-- the fold from within our accumulation function.
data FoldStatus
  = ContinueFold
  | StopFold
  | DebugFold
  deriving (Int -> FoldStatus -> ShowS
[FoldStatus] -> ShowS
FoldStatus -> String
(Int -> FoldStatus -> ShowS)
-> (FoldStatus -> String)
-> ([FoldStatus] -> ShowS)
-> Show FoldStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FoldStatus -> ShowS
showsPrec :: Int -> FoldStatus -> ShowS
$cshow :: FoldStatus -> String
show :: FoldStatus -> String
$cshowList :: [FoldStatus] -> ShowS
showList :: [FoldStatus] -> ShowS
Show, FoldStatus -> FoldStatus -> Bool
(FoldStatus -> FoldStatus -> Bool)
-> (FoldStatus -> FoldStatus -> Bool) -> Eq FoldStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FoldStatus -> FoldStatus -> Bool
== :: FoldStatus -> FoldStatus -> Bool
$c/= :: FoldStatus -> FoldStatus -> Bool
/= :: FoldStatus -> FoldStatus -> Bool
Eq)

-- | Monadic fold over all blocks and ledger states. Stopping @k@ blocks before
-- the node's tip where @k@ is the security parameter.
foldBlocks
  :: forall a t m
   . ()
  => Show a
  => MonadIOTransError FoldBlocksError t m
  => NodeConfigFile 'In
  -- ^ Path to the cardano-node config file (e.g. <path to cardano-node project>/configuration/cardano/mainnet-config.json)
  -> SocketPath
  -- ^ Path to local cardano-node socket. This is the path specified by the @--socket-path@ command line option when running the node.
  -> ValidationMode
  -> a
  -- ^ The initial accumulator state.
  -> (Env -> LedgerState -> [LedgerEvent] -> BlockInMode -> a -> IO (a, FoldStatus))
  -- ^ Accumulator function Takes:
  --
  --  * Environment (this is a constant over the whole fold).
  --  * The Ledger state (with block @i@ applied) at block @i@.
  --  * The Ledger events resulting from applying block @i@.
  --  * Block @i@.
  --  * The accumulator state at block @i - 1@.
  --
  -- And returns:
  --
  --  * The accumulator state at block @i@
  --  * A type indicating whether to stop or continue folding.
  --
  -- Note: This function can safely assume no rollback will occur even though
  -- internally this is implemented with a client protocol that may require
  -- rollback. This is achieved by only calling the accumulator on states/blocks
  -- that are older than the security parameter, k. This has the side effect of
  -- truncating the last k blocks before the node's tip.
  -> t m a
  -- ^ The final state
foldBlocks :: forall a (t :: (* -> *) -> * -> *) (m :: * -> *).
(Show a, MonadIOTransError FoldBlocksError t m) =>
NodeConfigFile 'In
-> SocketPath
-> ValidationMode
-> a
-> (Env
    -> LedgerState
    -> [LedgerEvent]
    -> BlockInMode
    -> a
    -> IO (a, FoldStatus))
-> t m a
foldBlocks NodeConfigFile 'In
nodeConfigFilePath SocketPath
socketPath ValidationMode
validationMode a
state0 Env
-> LedgerState
-> [LedgerEvent]
-> BlockInMode
-> a
-> IO (a, FoldStatus)
accumulate = ExceptT FoldBlocksError IO a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadIOTransError FoldBlocksError t m =>
ExceptT FoldBlocksError IO a -> t m a
handleExceptions (ExceptT FoldBlocksError IO a -> t m a)
-> ExceptT FoldBlocksError IO a -> t m a
forall a b. (a -> b) -> a -> b
$ do
  -- NOTE this was originally implemented with a non-pipelined client then
  -- changed to a pipelined client for a modest speedup:
  --  * Non-pipelined: 1h  0m  19s
  --  * Pipelined:        46m  23s

  (Env
env, LedgerState
ledgerState) <-
    (InitialLedgerStateError -> FoldBlocksError)
-> ExceptT InitialLedgerStateError IO (Env, LedgerState)
-> ExceptT FoldBlocksError IO (Env, LedgerState)
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError InitialLedgerStateError -> FoldBlocksError
FoldBlocksInitialLedgerStateError (ExceptT InitialLedgerStateError IO (Env, LedgerState)
 -> ExceptT FoldBlocksError IO (Env, LedgerState))
-> ExceptT InitialLedgerStateError IO (Env, LedgerState)
-> ExceptT FoldBlocksError IO (Env, LedgerState)
forall a b. (a -> b) -> a -> b
$ NodeConfigFile 'In
-> ExceptT InitialLedgerStateError IO (Env, LedgerState)
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError InitialLedgerStateError t m =>
NodeConfigFile 'In -> t m (Env, LedgerState)
initialLedgerState NodeConfigFile 'In
nodeConfigFilePath

  -- Place to store the accumulated state
  -- This is a bit ugly, but easy.
  IORef (Maybe LedgerStateError)
errorIORef <- IO (IORef (Maybe LedgerStateError))
-> ExceptT FoldBlocksError IO (IORef (Maybe LedgerStateError))
forall a. IO a -> ExceptT FoldBlocksError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Maybe LedgerStateError))
 -> ExceptT FoldBlocksError IO (IORef (Maybe LedgerStateError)))
-> IO (IORef (Maybe LedgerStateError))
-> ExceptT FoldBlocksError IO (IORef (Maybe LedgerStateError))
forall a b. (a -> b) -> a -> b
$ Maybe LedgerStateError -> IO (IORef (Maybe LedgerStateError))
forall a. a -> IO (IORef a)
newIORef Maybe LedgerStateError
forall a. Maybe a
Nothing
  IORef a
stateIORef <- IO (IORef a) -> ExceptT FoldBlocksError IO (IORef a)
forall a. IO a -> ExceptT FoldBlocksError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef a) -> ExceptT FoldBlocksError IO (IORef a))
-> IO (IORef a) -> ExceptT FoldBlocksError IO (IORef a)
forall a b. (a -> b) -> a -> b
$ a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
state0

  -- Derive the NetworkId as described in network-magic.md from the
  -- cardano-ledger-specs repo.
  let byronConfig :: Config
byronConfig =
        (\(Consensus.WrapPartialLedgerConfig (Consensus.ByronPartialLedgerConfig LedgerConfig ByronBlock
bc TriggerHardFork
_) :* NP WrapPartialLedgerConfig xs1
_) -> Config
LedgerConfig ByronBlock
bc)
          (NP
   WrapPartialLedgerConfig
   (ByronBlock : CardanoShelleyEras StandardCrypto)
 -> Config)
-> (CardanoLedgerConfig StandardCrypto
    -> NP
         WrapPartialLedgerConfig
         (ByronBlock : CardanoShelleyEras StandardCrypto))
-> CardanoLedgerConfig StandardCrypto
-> Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerEraLedgerConfig (ByronBlock : CardanoShelleyEras StandardCrypto)
-> NP
     WrapPartialLedgerConfig
     (ByronBlock : CardanoShelleyEras StandardCrypto)
forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
HFC.getPerEraLedgerConfig
          (PerEraLedgerConfig
   (ByronBlock : CardanoShelleyEras StandardCrypto)
 -> NP
      WrapPartialLedgerConfig
      (ByronBlock : CardanoShelleyEras StandardCrypto))
-> (CardanoLedgerConfig StandardCrypto
    -> PerEraLedgerConfig
         (ByronBlock : CardanoShelleyEras StandardCrypto))
-> CardanoLedgerConfig StandardCrypto
-> NP
     WrapPartialLedgerConfig
     (ByronBlock : CardanoShelleyEras StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoLedgerConfig StandardCrypto
-> PerEraLedgerConfig
     (ByronBlock : CardanoShelleyEras StandardCrypto)
forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
HFC.hardForkLedgerConfigPerEra
          (CardanoLedgerConfig StandardCrypto -> Config)
-> CardanoLedgerConfig StandardCrypto -> Config
forall a b. (a -> b) -> a -> b
$ Env -> CardanoLedgerConfig StandardCrypto
envLedgerConfig Env
env

      networkMagic :: NetworkMagic
networkMagic =
        Word32 -> NetworkMagic
NetworkMagic (Word32 -> NetworkMagic) -> Word32 -> NetworkMagic
forall a b. (a -> b) -> a -> b
$
          ProtocolMagicId -> Word32
unProtocolMagicId (ProtocolMagicId -> Word32) -> ProtocolMagicId -> Word32
forall a b. (a -> b) -> a -> b
$
            GenesisData -> ProtocolMagicId
Cardano.Chain.Genesis.gdProtocolMagicId (GenesisData -> ProtocolMagicId) -> GenesisData -> ProtocolMagicId
forall a b. (a -> b) -> a -> b
$
              Config -> GenesisData
Cardano.Chain.Genesis.configGenesisData Config
byronConfig

      networkId' :: NetworkId
networkId' = case Config -> RequiresNetworkMagic
Cardano.Chain.Genesis.configReqNetMagic Config
byronConfig of
        RequiresNetworkMagic
RequiresNoMagic -> NetworkId
Mainnet
        RequiresNetworkMagic
RequiresMagic -> NetworkMagic -> NetworkId
Testnet NetworkMagic
networkMagic

      cardanoModeParams :: ConsensusModeParams
cardanoModeParams = EpochSlots -> ConsensusModeParams
CardanoModeParams (EpochSlots -> ConsensusModeParams)
-> (Word64 -> EpochSlots) -> Word64 -> ConsensusModeParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> EpochSlots
EpochSlots (Word64 -> ConsensusModeParams) -> Word64 -> ConsensusModeParams
forall a b. (a -> b) -> a -> b
$ Word64
10 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Env -> Word64
envSecurityParam Env
env

  -- Connect to the node.
  let connectInfo :: LocalNodeConnectInfo
connectInfo =
        LocalNodeConnectInfo
          { localConsensusModeParams :: ConsensusModeParams
localConsensusModeParams = ConsensusModeParams
cardanoModeParams
          , localNodeNetworkId :: NetworkId
localNodeNetworkId = NetworkId
networkId'
          , localNodeSocketPath :: SocketPath
localNodeSocketPath = SocketPath
socketPath
          }

  IO () -> ExceptT FoldBlocksError IO ()
forall a. IO a -> ExceptT FoldBlocksError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT FoldBlocksError IO ())
-> IO () -> ExceptT FoldBlocksError IO ()
forall a b. (a -> b) -> a -> b
$
    LocalNodeConnectInfo -> LocalNodeClientProtocolsInMode -> IO ()
forall (m :: * -> *).
MonadIO m =>
LocalNodeConnectInfo -> LocalNodeClientProtocolsInMode -> m ()
connectToLocalNode
      LocalNodeConnectInfo
connectInfo
      (IORef a
-> IORef (Maybe LedgerStateError)
-> Env
-> LedgerState
-> LocalNodeClientProtocolsInMode
protocols IORef a
stateIORef IORef (Maybe LedgerStateError)
errorIORef Env
env LedgerState
ledgerState)

  IO (Maybe LedgerStateError)
-> ExceptT FoldBlocksError IO (Maybe LedgerStateError)
forall a. IO a -> ExceptT FoldBlocksError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe LedgerStateError) -> IO (Maybe LedgerStateError)
forall a. IORef a -> IO a
readIORef IORef (Maybe LedgerStateError)
errorIORef) ExceptT FoldBlocksError IO (Maybe LedgerStateError)
-> (Maybe LedgerStateError -> ExceptT FoldBlocksError IO a)
-> ExceptT FoldBlocksError IO a
forall a b.
ExceptT FoldBlocksError IO a
-> (a -> ExceptT FoldBlocksError IO b)
-> ExceptT FoldBlocksError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just LedgerStateError
err -> FoldBlocksError -> ExceptT FoldBlocksError IO a
forall a. FoldBlocksError -> ExceptT FoldBlocksError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LedgerStateError -> FoldBlocksError
FoldBlocksApplyBlockError LedgerStateError
err)
    Maybe LedgerStateError
Nothing -> IO a -> ExceptT FoldBlocksError IO a
forall a. IO a -> ExceptT FoldBlocksError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ExceptT FoldBlocksError IO a)
-> IO a -> ExceptT FoldBlocksError IO a
forall a b. (a -> b) -> a -> b
$ IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
stateIORef
 where
  protocols
    :: ()
    => IORef a
    -> IORef (Maybe LedgerStateError)
    -> Env
    -> LedgerState
    -> LocalNodeClientProtocolsInMode
  protocols :: IORef a
-> IORef (Maybe LedgerStateError)
-> Env
-> LedgerState
-> LocalNodeClientProtocolsInMode
protocols IORef a
stateIORef IORef (Maybe LedgerStateError)
errorIORef Env
env LedgerState
ledgerState =
    LocalNodeClientProtocols
      { localChainSyncClient :: LocalChainSyncClient BlockInMode ChainPoint ChainTip IO
localChainSyncClient =
          ChainSyncClientPipelined BlockInMode ChainPoint ChainTip IO ()
-> LocalChainSyncClient BlockInMode ChainPoint ChainTip IO
forall block point tip (m :: * -> *).
ChainSyncClientPipelined block point tip m ()
-> LocalChainSyncClient block point tip m
LocalChainSyncClientPipelined (Word16
-> IORef a
-> IORef (Maybe LedgerStateError)
-> Env
-> LedgerState
-> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip IO ()
chainSyncClient Word16
50 IORef a
stateIORef IORef (Maybe LedgerStateError)
errorIORef Env
env LedgerState
ledgerState)
      , localTxSubmissionClient :: Maybe
  (LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode IO ())
localTxSubmissionClient = Maybe
  (LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode IO ())
forall a. Maybe a
Nothing
      , localStateQueryClient :: Maybe
  (LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ())
localStateQueryClient = Maybe
  (LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ())
forall a. Maybe a
Nothing
      , localTxMonitoringClient :: Maybe (LocalTxMonitorClient TxIdInMode TxInMode SlotNo IO ())
localTxMonitoringClient = Maybe (LocalTxMonitorClient TxIdInMode TxInMode SlotNo IO ())
forall a. Maybe a
Nothing
      }

  -- \| Defines the client side of the chain sync protocol.
  chainSyncClient
    :: Word16
    -- \^ The maximum number of concurrent requests.
    -> IORef a
    -- \^ State accumulator. Written to on every block.
    -> IORef (Maybe LedgerStateError)
    -- \^ Resulting error if any. Written to once on protocol
    -- completion.
    -> Env
    -> LedgerState
    -> CSP.ChainSyncClientPipelined
        BlockInMode
        ChainPoint
        ChainTip
        IO
        ()
  -- \^ Client returns maybe an error.
  chainSyncClient :: Word16
-> IORef a
-> IORef (Maybe LedgerStateError)
-> Env
-> LedgerState
-> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip IO ()
chainSyncClient Word16
pipelineSize IORef a
stateIORef IORef (Maybe LedgerStateError)
errorIORef Env
env LedgerState
ledgerState0 =
    IO (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ())
-> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip IO ()
forall header point tip (m :: * -> *) a.
m (ClientPipelinedStIdle 'Z header point tip m a)
-> ChainSyncClientPipelined header point tip m a
CSP.ChainSyncClientPipelined (IO
   (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ())
 -> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip IO ())
-> IO
     (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ())
-> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip IO ()
forall a b. (a -> b) -> a -> b
$
      ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ()
 -> IO
      (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ()))
-> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ())
forall a b. (a -> b) -> a -> b
$
        WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat 'Z
-> History LedgerStateEvents
-> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History LedgerStateEvents
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
forall t. WithOrigin t
Origin WithOrigin BlockNo
forall t. WithOrigin t
Origin Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero History LedgerStateEvents
initialLedgerStateHistory
   where
    initialLedgerStateHistory :: History LedgerStateEvents
initialLedgerStateHistory = (SlotNo, LedgerStateEvents, WithOrigin BlockInMode)
-> History LedgerStateEvents
forall a. a -> Seq a
Seq.singleton (SlotNo
0, (LedgerState
ledgerState0, []), WithOrigin BlockInMode
forall t. WithOrigin t
Origin)

    clientIdle_RequestMoreN
      :: WithOrigin BlockNo
      -> WithOrigin BlockNo
      -> Nat n -- Number of requests inflight.
      -> LedgerStateHistory
      -> CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
    clientIdle_RequestMoreN :: forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History LedgerStateEvents
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
clientTip WithOrigin BlockNo
serverTip Nat n
n History LedgerStateEvents
knownLedgerStates =
      case Word16
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> PipelineDecision n
forall (n :: N).
Word16
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> PipelineDecision n
pipelineDecisionMax Word16
pipelineSize Nat n
n WithOrigin BlockNo
clientTip WithOrigin BlockNo
serverTip of
        PipelineDecision n
Collect -> case Nat n
n of
          Succ Nat n
predN -> Maybe
  (IO
     (ClientPipelinedStIdle
        ('S n) BlockInMode ChainPoint ChainTip IO ()))
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
-> ClientPipelinedStIdle
     ('S n) BlockInMode ChainPoint ChainTip IO ()
forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CSP.CollectResponse Maybe
  (IO
     (ClientPipelinedStIdle
        ('S n) BlockInMode ChainPoint ChainTip IO ()))
forall a. Maybe a
Nothing (Nat n
-> History LedgerStateEvents
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
forall (n :: N).
Nat n
-> History LedgerStateEvents
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
clientNextN Nat n
predN History LedgerStateEvents
knownLedgerStates)
        PipelineDecision n
_ ->
          IO ()
-> ClientPipelinedStIdle
     ('S n) BlockInMode ChainPoint ChainTip IO ()
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
forall (m :: * -> *) (n :: N) header point tip a.
m ()
-> ClientPipelinedStIdle ('S n) header point tip m a
-> ClientPipelinedStIdle n header point tip m a
CSP.SendMsgRequestNextPipelined
            (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
            (WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat ('S n)
-> History LedgerStateEvents
-> ClientPipelinedStIdle
     ('S n) BlockInMode ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History LedgerStateEvents
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
clientTip WithOrigin BlockNo
serverTip (Nat n -> Nat ('S n)
forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat n
n) History LedgerStateEvents
knownLedgerStates)

    clientNextN
      :: Nat n -- Number of requests inflight.
      -> LedgerStateHistory
      -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO ()
    clientNextN :: forall (n :: N).
Nat n
-> History LedgerStateEvents
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
clientNextN Nat n
n History LedgerStateEvents
knownLedgerStates =
      CSP.ClientStNext
        { recvMsgRollForward :: BlockInMode
-> ChainTip
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
CSP.recvMsgRollForward = \blockInMode :: BlockInMode
blockInMode@(BlockInMode CardanoEra era
_ (Block (BlockHeader SlotNo
slotNo Hash BlockHeader
_ BlockNo
currBlockNo) [Tx era]
_)) ChainTip
serverChainTip -> do
            let newLedgerStateE :: Either LedgerStateError LedgerStateEvents
newLedgerStateE =
                  Env
-> LedgerState
-> ValidationMode
-> BlockInMode
-> Either LedgerStateError LedgerStateEvents
applyBlock
                    Env
env
                    ( LedgerState
-> ((SlotNo, LedgerStateEvents, WithOrigin BlockInMode)
    -> LedgerState)
-> Maybe (SlotNo, LedgerStateEvents, WithOrigin BlockInMode)
-> LedgerState
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                        (String -> LedgerState
forall a. HasCallStack => String -> a
error String
"Impossible! Missing Ledger state")
                        (\(SlotNo
_, (LedgerState
ledgerState, [LedgerEvent]
_), WithOrigin BlockInMode
_) -> LedgerState
ledgerState)
                        (Int
-> History LedgerStateEvents
-> Maybe (SlotNo, LedgerStateEvents, WithOrigin BlockInMode)
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
0 History LedgerStateEvents
knownLedgerStates)
                    )
                    ValidationMode
validationMode
                    BlockInMode
blockInMode
            case Either LedgerStateError LedgerStateEvents
newLedgerStateE of
              Left LedgerStateError
err -> Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
clientIdle_DoneNwithMaybeError Nat n
n (LedgerStateError -> Maybe LedgerStateError
forall a. a -> Maybe a
Just LedgerStateError
err)
              Right LedgerStateEvents
newLedgerState -> do
                let (History LedgerStateEvents
knownLedgerStates', History LedgerStateEvents
committedStates) = Env
-> History LedgerStateEvents
-> SlotNo
-> LedgerStateEvents
-> BlockInMode
-> (History LedgerStateEvents, History LedgerStateEvents)
forall a.
Env
-> History a
-> SlotNo
-> a
-> BlockInMode
-> (History a, History a)
pushLedgerState Env
env History LedgerStateEvents
knownLedgerStates SlotNo
slotNo LedgerStateEvents
newLedgerState BlockInMode
blockInMode
                    newClientTip :: WithOrigin BlockNo
newClientTip = BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At BlockNo
currBlockNo
                    newServerTip :: WithOrigin BlockNo
newServerTip = ChainTip -> WithOrigin BlockNo
fromChainTip ChainTip
serverChainTip

                    ledgerStateSingleFold
                      :: (SlotNo, (LedgerState, [LedgerEvent]), WithOrigin BlockInMode) -- Ledger events for a single block
                      -> IO FoldStatus
                    ledgerStateSingleFold :: (SlotNo, LedgerStateEvents, WithOrigin BlockInMode)
-> IO FoldStatus
ledgerStateSingleFold (SlotNo
_, LedgerStateEvents
_, WithOrigin BlockInMode
Origin) = FoldStatus -> IO FoldStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FoldStatus
ContinueFold
                    ledgerStateSingleFold (SlotNo
_, (LedgerState
ledgerState, [LedgerEvent]
ledgerEvents), At BlockInMode
currBlock) = do
                      a
accumulatorState <- IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
stateIORef
                      (a
newState, FoldStatus
foldStatus) <-
                        Env
-> LedgerState
-> [LedgerEvent]
-> BlockInMode
-> a
-> IO (a, FoldStatus)
accumulate
                          Env
env
                          LedgerState
ledgerState
                          [LedgerEvent]
ledgerEvents
                          BlockInMode
currBlock
                          a
accumulatorState
                      IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef a
stateIORef a
newState
                      FoldStatus -> IO FoldStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FoldStatus
foldStatus

                    ledgerStateRecurser
                      :: Seq (SlotNo, LedgerStateEvents, WithOrigin BlockInMode) -- Ledger events for multiple blocks
                      -> IO FoldStatus
                    ledgerStateRecurser :: History LedgerStateEvents -> IO FoldStatus
ledgerStateRecurser History LedgerStateEvents
states = [(SlotNo, LedgerStateEvents, WithOrigin BlockInMode)]
-> FoldStatus -> IO FoldStatus
go (History LedgerStateEvents -> [Item (History LedgerStateEvents)]
forall l. IsList l => l -> [Item l]
toList History LedgerStateEvents
states) FoldStatus
ContinueFold
                     where
                      go :: [(SlotNo, LedgerStateEvents, WithOrigin BlockInMode)]
-> FoldStatus -> IO FoldStatus
go [] FoldStatus
foldStatus = FoldStatus -> IO FoldStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FoldStatus
foldStatus
                      go ((SlotNo, LedgerStateEvents, WithOrigin BlockInMode)
s : [(SlotNo, LedgerStateEvents, WithOrigin BlockInMode)]
rest) FoldStatus
ContinueFold = do
                        FoldStatus
newFoldStatus <- (SlotNo, LedgerStateEvents, WithOrigin BlockInMode)
-> IO FoldStatus
ledgerStateSingleFold (SlotNo, LedgerStateEvents, WithOrigin BlockInMode)
s
                        [(SlotNo, LedgerStateEvents, WithOrigin BlockInMode)]
-> FoldStatus -> IO FoldStatus
go [(SlotNo, LedgerStateEvents, WithOrigin BlockInMode)]
rest FoldStatus
newFoldStatus
                      go [(SlotNo, LedgerStateEvents, WithOrigin BlockInMode)]
_ FoldStatus
StopFold = [(SlotNo, LedgerStateEvents, WithOrigin BlockInMode)]
-> FoldStatus -> IO FoldStatus
go [] FoldStatus
StopFold
                      go [(SlotNo, LedgerStateEvents, WithOrigin BlockInMode)]
_ FoldStatus
DebugFold = [(SlotNo, LedgerStateEvents, WithOrigin BlockInMode)]
-> FoldStatus -> IO FoldStatus
go [] FoldStatus
DebugFold

                -- NB: knownLedgerStates' is the new ledger state history i.e k blocks from the tip
                -- or also known as the mutable blocks. We default to using the mutable blocks.
                FoldStatus
finalFoldStatus <- History LedgerStateEvents -> IO FoldStatus
ledgerStateRecurser History LedgerStateEvents
knownLedgerStates'

                case FoldStatus
finalFoldStatus of
                  FoldStatus
StopFold ->
                    -- We return StopFold in our accumulate function if we want to terminate the fold.
                    -- This allow us to check for a specific condition in our accumulate function
                    -- and then terminate e.g a specific stake pool was registered
                    let noError :: Maybe a
noError = Maybe a
forall a. Maybe a
Nothing
                     in Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
clientIdle_DoneNwithMaybeError Nat n
n Maybe LedgerStateError
forall a. Maybe a
noError
                  FoldStatus
DebugFold -> do
                    a
currentIORefState <- IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
stateIORef

                    -- Useful for debugging:
                    let !ioRefErr :: LedgerStateError
ioRefErr =
                          String -> LedgerStateError
DebugError (String -> LedgerStateError) -> ShowS -> String -> LedgerStateError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. NFData a => a -> a
force (String -> LedgerStateError) -> String -> LedgerStateError
forall a b. (a -> b) -> a -> b
$
                            [String] -> String
unlines
                              [ String
"newClientTip: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> WithOrigin BlockNo -> String
forall a. Show a => a -> String
show WithOrigin BlockNo
newClientTip
                              , String
"newServerTip: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> WithOrigin BlockNo -> String
forall a. Show a => a -> String
show WithOrigin BlockNo
newServerTip
                              , String
"newLedgerState: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [LedgerEvent] -> String
forall a. Show a => a -> String
show (LedgerStateEvents -> [LedgerEvent]
forall a b. (a, b) -> b
snd LedgerStateEvents
newLedgerState)
                              , String
"knownLedgerStates: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [(SlotNo, [LedgerEvent], BlockNo)] -> String
forall a. Show a => a -> String
show (History LedgerStateEvents -> [(SlotNo, [LedgerEvent], BlockNo)]
extractHistory History LedgerStateEvents
knownLedgerStates)
                              , String
"committedStates: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [(SlotNo, [LedgerEvent], BlockNo)] -> String
forall a. Show a => a -> String
show (History LedgerStateEvents -> [(SlotNo, [LedgerEvent], BlockNo)]
extractHistory History LedgerStateEvents
committedStates)
                              , String
"numberOfRequestsInFlight: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Nat n -> String
forall a. Show a => a -> String
show Nat n
n
                              , String
"k: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a. Show a => a -> String
show (Env -> Word64
envSecurityParam Env
env)
                              , String
"Current IORef State: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
currentIORefState
                              ]
                    Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
clientIdle_DoneNwithMaybeError Nat n
n (Maybe LedgerStateError
 -> IO
      (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()))
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall a b. (a -> b) -> a -> b
$ LedgerStateError -> Maybe LedgerStateError
forall a. a -> Maybe a
Just LedgerStateError
ioRefErr
                  FoldStatus
ContinueFold -> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
 -> IO
      (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()))
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall a b. (a -> b) -> a -> b
$ WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History LedgerStateEvents
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History LedgerStateEvents
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
newClientTip WithOrigin BlockNo
newServerTip Nat n
n History LedgerStateEvents
knownLedgerStates'
        , recvMsgRollBackward :: ChainPoint
-> ChainTip
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
CSP.recvMsgRollBackward = \ChainPoint
chainPoint ChainTip
serverChainTip -> do
            let newClientTip :: WithOrigin t
newClientTip = WithOrigin t
forall t. WithOrigin t
Origin -- We don't actually keep track of blocks so we temporarily "forget" the tip.
                newServerTip :: WithOrigin BlockNo
newServerTip = ChainTip -> WithOrigin BlockNo
fromChainTip ChainTip
serverChainTip
                truncatedKnownLedgerStates :: History LedgerStateEvents
truncatedKnownLedgerStates = case ChainPoint
chainPoint of
                  ChainPoint
ChainPointAtGenesis -> History LedgerStateEvents
initialLedgerStateHistory
                  ChainPoint SlotNo
slotNo Hash BlockHeader
_ -> History LedgerStateEvents -> SlotNo -> History LedgerStateEvents
forall a. History a -> SlotNo -> History a
rollBackLedgerStateHist History LedgerStateEvents
knownLedgerStates SlotNo
slotNo
            ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History LedgerStateEvents
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History LedgerStateEvents
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
forall t. WithOrigin t
newClientTip WithOrigin BlockNo
newServerTip Nat n
n History LedgerStateEvents
truncatedKnownLedgerStates)
        }

    clientIdle_DoneNwithMaybeError
      :: Nat n -- Number of requests inflight.
      -> Maybe LedgerStateError -- Return value (maybe an error)
      -> IO (CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
    clientIdle_DoneNwithMaybeError :: forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
clientIdle_DoneNwithMaybeError Nat n
n Maybe LedgerStateError
errorMay = case Nat n
n of
      Succ Nat n
predN -> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
  (IO
     (ClientPipelinedStIdle
        ('S n) BlockInMode ChainPoint ChainTip IO ()))
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
-> ClientPipelinedStIdle
     ('S n) BlockInMode ChainPoint ChainTip IO ()
forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CSP.CollectResponse Maybe
  (IO
     (ClientPipelinedStIdle
        ('S n) BlockInMode ChainPoint ChainTip IO ()))
forall a. Maybe a
Nothing (Nat n
-> Maybe LedgerStateError
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
clientNext_DoneNwithMaybeError Nat n
predN Maybe LedgerStateError
errorMay)) -- Ignore remaining message responses
      Nat n
Zero -> do
        IORef (Maybe LedgerStateError) -> Maybe LedgerStateError -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe LedgerStateError)
errorIORef Maybe LedgerStateError
errorMay
        ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (()
-> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ()
forall a header point tip (m :: * -> *).
a -> ClientPipelinedStIdle 'Z header point tip m a
CSP.SendMsgDone ())

    clientNext_DoneNwithMaybeError
      :: Nat n -- Number of requests inflight.
      -> Maybe LedgerStateError -- Return value (maybe an error)
      -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO ()
    clientNext_DoneNwithMaybeError :: forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
clientNext_DoneNwithMaybeError Nat n
n Maybe LedgerStateError
errorMay =
      CSP.ClientStNext
        { recvMsgRollForward :: BlockInMode
-> ChainTip
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
CSP.recvMsgRollForward = \BlockInMode
_ ChainTip
_ -> Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
clientIdle_DoneNwithMaybeError Nat n
n Maybe LedgerStateError
errorMay
        , recvMsgRollBackward :: ChainPoint
-> ChainTip
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
CSP.recvMsgRollBackward = \ChainPoint
_ ChainTip
_ -> Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
clientIdle_DoneNwithMaybeError Nat n
n Maybe LedgerStateError
errorMay
        }

    fromChainTip :: ChainTip -> WithOrigin BlockNo
    fromChainTip :: ChainTip -> WithOrigin BlockNo
fromChainTip ChainTip
ct = case ChainTip
ct of
      ChainTip
ChainTipAtGenesis -> WithOrigin BlockNo
forall t. WithOrigin t
Origin
      ChainTip SlotNo
_ Hash BlockHeader
_ BlockNo
bno -> BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At BlockNo
bno

-- | Wrap a 'ChainSyncClient' with logic that tracks the ledger state.
chainSyncClientWithLedgerState
  :: forall m a
   . Monad m
  => Env
  -> LedgerState
  -- ^ Initial ledger state
  -> ValidationMode
  -> CS.ChainSyncClient
      (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent]))
      ChainPoint
      ChainTip
      m
      a
  -- ^ A client to wrap. The block is annotated with a 'Either LedgerStateError
  -- LedgerState'. This is either an error from validating a block or
  -- the current 'LedgerState' from applying the current block. If we
  -- trust the node, then we generally expect blocks to validate. Also note that
  -- after a block fails to validate we may still roll back to a validated
  -- block, in which case the valid 'LedgerState' will be passed here again.
  -> CS.ChainSyncClient
      BlockInMode
      ChainPoint
      ChainTip
      m
      a
  -- ^ A client that acts just like the wrapped client but doesn't require the
  -- 'LedgerState' annotation on the block type.
chainSyncClientWithLedgerState :: forall (m :: * -> *) a.
Monad m =>
Env
-> LedgerState
-> ValidationMode
-> ChainSyncClient
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ChainSyncClient BlockInMode ChainPoint ChainTip m a
chainSyncClientWithLedgerState Env
env LedgerState
ledgerState0 ValidationMode
validationMode (CS.ChainSyncClient m (ClientStIdle
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a)
clientTop) =
  m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> ChainSyncClient BlockInMode ChainPoint ChainTip m a
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
CS.ChainSyncClient (Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> ClientStIdle
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle BlockInMode ChainPoint ChainTip m a
goClientStIdle (History (Either LedgerStateError LedgerStateEvents)
-> Either
     LedgerStateError
     (History (Either LedgerStateError LedgerStateEvents))
forall a b. b -> Either a b
Right History (Either LedgerStateError LedgerStateEvents)
initialLedgerStateHistory) (ClientStIdle
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientStIdle
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a)
clientTop)
 where
  goClientStIdle
    :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents))
    -> CS.ClientStIdle
        (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a
    -> CS.ClientStIdle
        BlockInMode
        ChainPoint
        ChainTip
        m
        a
  goClientStIdle :: Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> ClientStIdle
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle BlockInMode ChainPoint ChainTip m a
goClientStIdle Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history ClientStIdle
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
client = case ClientStIdle
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
client of
    CS.SendMsgRequestNext m ()
a ClientStNext
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
b -> m ()
-> ClientStNext BlockInMode ChainPoint ChainTip m a
-> ClientStIdle BlockInMode ChainPoint ChainTip m a
forall (m :: * -> *) header point tip a.
m ()
-> ClientStNext header point tip m a
-> ClientStIdle header point tip m a
CS.SendMsgRequestNext m ()
a (Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> ClientStNext
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext BlockInMode ChainPoint ChainTip m a
goClientStNext Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history ClientStNext
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
b)
    CS.SendMsgFindIntersect [ChainPoint]
ps ClientStIntersect
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
a -> [ChainPoint]
-> ClientStIntersect BlockInMode ChainPoint ChainTip m a
-> ClientStIdle BlockInMode ChainPoint ChainTip m a
forall point header tip (m :: * -> *) a.
[point]
-> ClientStIntersect header point tip m a
-> ClientStIdle header point tip m a
CS.SendMsgFindIntersect [ChainPoint]
ps (Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> ClientStIntersect
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIntersect BlockInMode ChainPoint ChainTip m a
goClientStIntersect Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history ClientStIntersect
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
a)
    CS.SendMsgDone a
a -> a -> ClientStIdle BlockInMode ChainPoint ChainTip m a
forall a header point tip (m :: * -> *).
a -> ClientStIdle header point tip m a
CS.SendMsgDone a
a

  -- This is where the magic happens. We intercept the blocks and rollbacks
  -- and use it to maintain the correct ledger state.
  goClientStNext
    :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents))
    -> CS.ClientStNext
        (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a
    -> CS.ClientStNext
        BlockInMode
        ChainPoint
        ChainTip
        m
        a
  goClientStNext :: Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> ClientStNext
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext BlockInMode ChainPoint ChainTip m a
goClientStNext (Left LedgerStateError
err) (CS.ClientStNext (BlockInMode, Either LedgerStateError LedgerStateEvents)
-> ChainTip
-> ChainSyncClient
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
recvMsgRollForward ChainPoint
-> ChainTip
-> ChainSyncClient
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
recvMsgRollBackward) =
    (BlockInMode
 -> ChainTip -> ChainSyncClient BlockInMode ChainPoint ChainTip m a)
-> (ChainPoint
    -> ChainTip -> ChainSyncClient BlockInMode ChainPoint ChainTip m a)
-> ClientStNext BlockInMode ChainPoint ChainTip m a
forall header point tip (m :: * -> *) a.
(header -> tip -> ChainSyncClient header point tip m a)
-> (point -> tip -> ChainSyncClient header point tip m a)
-> ClientStNext header point tip m a
CS.ClientStNext
      ( \BlockInMode
blkInMode ChainTip
tip ->
          m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> ChainSyncClient BlockInMode ChainPoint ChainTip m a
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
CS.ChainSyncClient (m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
 -> ChainSyncClient BlockInMode ChainPoint ChainTip m a)
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> ChainSyncClient BlockInMode ChainPoint ChainTip m a
forall a b. (a -> b) -> a -> b
$
            Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> ClientStIdle
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle BlockInMode ChainPoint ChainTip m a
goClientStIdle (LedgerStateError
-> Either
     LedgerStateError
     (History (Either LedgerStateError LedgerStateEvents))
forall a b. a -> Either a b
Left LedgerStateError
err)
              (ClientStIdle
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClient
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
-> m (ClientStIdle
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
forall header point tip (m :: * -> *) a.
ChainSyncClient header point tip m a
-> m (ClientStIdle header point tip m a)
CS.runChainSyncClient
                ((BlockInMode, Either LedgerStateError LedgerStateEvents)
-> ChainTip
-> ChainSyncClient
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
recvMsgRollForward (BlockInMode
blkInMode, LedgerStateError -> Either LedgerStateError LedgerStateEvents
forall a b. a -> Either a b
Left LedgerStateError
err) ChainTip
tip)
      )
      ( \ChainPoint
point ChainTip
tip ->
          m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> ChainSyncClient BlockInMode ChainPoint ChainTip m a
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
CS.ChainSyncClient (m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
 -> ChainSyncClient BlockInMode ChainPoint ChainTip m a)
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> ChainSyncClient BlockInMode ChainPoint ChainTip m a
forall a b. (a -> b) -> a -> b
$
            Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> ClientStIdle
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle BlockInMode ChainPoint ChainTip m a
goClientStIdle (LedgerStateError
-> Either
     LedgerStateError
     (History (Either LedgerStateError LedgerStateEvents))
forall a b. a -> Either a b
Left LedgerStateError
err) (ClientStIdle
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClient
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
-> m (ClientStIdle
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
forall header point tip (m :: * -> *) a.
ChainSyncClient header point tip m a
-> m (ClientStIdle header point tip m a)
CS.runChainSyncClient (ChainPoint
-> ChainTip
-> ChainSyncClient
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
recvMsgRollBackward ChainPoint
point ChainTip
tip)
      )
  goClientStNext (Right History (Either LedgerStateError LedgerStateEvents)
history) (CS.ClientStNext (BlockInMode, Either LedgerStateError LedgerStateEvents)
-> ChainTip
-> ChainSyncClient
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
recvMsgRollForward ChainPoint
-> ChainTip
-> ChainSyncClient
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
recvMsgRollBackward) =
    (BlockInMode
 -> ChainTip -> ChainSyncClient BlockInMode ChainPoint ChainTip m a)
-> (ChainPoint
    -> ChainTip -> ChainSyncClient BlockInMode ChainPoint ChainTip m a)
-> ClientStNext BlockInMode ChainPoint ChainTip m a
forall header point tip (m :: * -> *) a.
(header -> tip -> ChainSyncClient header point tip m a)
-> (point -> tip -> ChainSyncClient header point tip m a)
-> ClientStNext header point tip m a
CS.ClientStNext
      ( \blkInMode :: BlockInMode
blkInMode@(BlockInMode CardanoEra era
_ (Block (BlockHeader SlotNo
slotNo Hash BlockHeader
_ BlockNo
_) [Tx era]
_)) ChainTip
tip ->
          m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> ChainSyncClient BlockInMode ChainPoint ChainTip m a
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
CS.ChainSyncClient (m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
 -> ChainSyncClient BlockInMode ChainPoint ChainTip m a)
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> ChainSyncClient BlockInMode ChainPoint ChainTip m a
forall a b. (a -> b) -> a -> b
$
            let
              newLedgerStateE :: Either LedgerStateError LedgerStateEvents
newLedgerStateE = case Int
-> History (Either LedgerStateError LedgerStateEvents)
-> Maybe
     (SlotNo, Either LedgerStateError LedgerStateEvents,
      WithOrigin BlockInMode)
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
0 History (Either LedgerStateError LedgerStateEvents)
history of
                Maybe
  (SlotNo, Either LedgerStateError LedgerStateEvents,
   WithOrigin BlockInMode)
Nothing -> String -> Either LedgerStateError LedgerStateEvents
forall a. HasCallStack => String -> a
error String
"Impossible! History should always be non-empty"
                Just (SlotNo
_, Left LedgerStateError
err, WithOrigin BlockInMode
_) -> LedgerStateError -> Either LedgerStateError LedgerStateEvents
forall a b. a -> Either a b
Left LedgerStateError
err
                Just (SlotNo
_, Right (LedgerState
oldLedgerState, [LedgerEvent]
_), WithOrigin BlockInMode
_) ->
                  Env
-> LedgerState
-> ValidationMode
-> BlockInMode
-> Either LedgerStateError LedgerStateEvents
applyBlock
                    Env
env
                    LedgerState
oldLedgerState
                    ValidationMode
validationMode
                    BlockInMode
blkInMode
              (History (Either LedgerStateError LedgerStateEvents)
history', History (Either LedgerStateError LedgerStateEvents)
_) = Env
-> History (Either LedgerStateError LedgerStateEvents)
-> SlotNo
-> Either LedgerStateError LedgerStateEvents
-> BlockInMode
-> (History (Either LedgerStateError LedgerStateEvents),
    History (Either LedgerStateError LedgerStateEvents))
forall a.
Env
-> History a
-> SlotNo
-> a
-> BlockInMode
-> (History a, History a)
pushLedgerState Env
env History (Either LedgerStateError LedgerStateEvents)
history SlotNo
slotNo Either LedgerStateError LedgerStateEvents
newLedgerStateE BlockInMode
blkInMode
             in
              Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> ClientStIdle
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle BlockInMode ChainPoint ChainTip m a
goClientStIdle (History (Either LedgerStateError LedgerStateEvents)
-> Either
     LedgerStateError
     (History (Either LedgerStateError LedgerStateEvents))
forall a b. b -> Either a b
Right History (Either LedgerStateError LedgerStateEvents)
history')
                (ClientStIdle
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClient
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
-> m (ClientStIdle
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
forall header point tip (m :: * -> *) a.
ChainSyncClient header point tip m a
-> m (ClientStIdle header point tip m a)
CS.runChainSyncClient
                  ((BlockInMode, Either LedgerStateError LedgerStateEvents)
-> ChainTip
-> ChainSyncClient
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
recvMsgRollForward (BlockInMode
blkInMode, Either LedgerStateError LedgerStateEvents
newLedgerStateE) ChainTip
tip)
      )
      ( \ChainPoint
point ChainTip
tip ->
          let
            oldestSlot :: SlotNo
oldestSlot = case History (Either LedgerStateError LedgerStateEvents)
history of
              History (Either LedgerStateError LedgerStateEvents)
_ Seq.:|> (SlotNo
s, Either LedgerStateError LedgerStateEvents
_, WithOrigin BlockInMode
_) -> SlotNo
s
              History (Either LedgerStateError LedgerStateEvents)
Seq.Empty -> String -> SlotNo
forall a. HasCallStack => String -> a
error String
"Impossible! History should always be non-empty"
            history' :: Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history' = ( \History (Either LedgerStateError LedgerStateEvents)
h ->
                          if History (Either LedgerStateError LedgerStateEvents) -> Bool
forall a. Seq a -> Bool
Seq.null History (Either LedgerStateError LedgerStateEvents)
h
                            then LedgerStateError
-> Either
     LedgerStateError
     (History (Either LedgerStateError LedgerStateEvents))
forall a b. a -> Either a b
Left (SlotNo -> ChainPoint -> LedgerStateError
InvalidRollback SlotNo
oldestSlot ChainPoint
point)
                            else History (Either LedgerStateError LedgerStateEvents)
-> Either
     LedgerStateError
     (History (Either LedgerStateError LedgerStateEvents))
forall a b. b -> Either a b
Right History (Either LedgerStateError LedgerStateEvents)
h
                       )
              (History (Either LedgerStateError LedgerStateEvents)
 -> Either
      LedgerStateError
      (History (Either LedgerStateError LedgerStateEvents)))
-> History (Either LedgerStateError LedgerStateEvents)
-> Either
     LedgerStateError
     (History (Either LedgerStateError LedgerStateEvents))
forall a b. (a -> b) -> a -> b
$ case ChainPoint
point of
                ChainPoint
ChainPointAtGenesis -> History (Either LedgerStateError LedgerStateEvents)
initialLedgerStateHistory
                ChainPoint SlotNo
slotNo Hash BlockHeader
_ -> History (Either LedgerStateError LedgerStateEvents)
-> SlotNo -> History (Either LedgerStateError LedgerStateEvents)
forall a. History a -> SlotNo -> History a
rollBackLedgerStateHist History (Either LedgerStateError LedgerStateEvents)
history SlotNo
slotNo
           in
            m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> ChainSyncClient BlockInMode ChainPoint ChainTip m a
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
CS.ChainSyncClient (m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
 -> ChainSyncClient BlockInMode ChainPoint ChainTip m a)
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> ChainSyncClient BlockInMode ChainPoint ChainTip m a
forall a b. (a -> b) -> a -> b
$
              Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> ClientStIdle
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle BlockInMode ChainPoint ChainTip m a
goClientStIdle Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history' (ClientStIdle
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClient
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
-> m (ClientStIdle
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
forall header point tip (m :: * -> *) a.
ChainSyncClient header point tip m a
-> m (ClientStIdle header point tip m a)
CS.runChainSyncClient (ChainPoint
-> ChainTip
-> ChainSyncClient
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
recvMsgRollBackward ChainPoint
point ChainTip
tip)
      )

  goClientStIntersect
    :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents))
    -> CS.ClientStIntersect
        (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a
    -> CS.ClientStIntersect
        BlockInMode
        ChainPoint
        ChainTip
        m
        a
  goClientStIntersect :: Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> ClientStIntersect
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIntersect BlockInMode ChainPoint ChainTip m a
goClientStIntersect Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history (CS.ClientStIntersect ChainPoint
-> ChainTip
-> ChainSyncClient
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
recvMsgIntersectFound ChainTip
-> ChainSyncClient
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
recvMsgIntersectNotFound) =
    (ChainPoint
 -> ChainTip -> ChainSyncClient BlockInMode ChainPoint ChainTip m a)
-> (ChainTip
    -> ChainSyncClient BlockInMode ChainPoint ChainTip m a)
-> ClientStIntersect BlockInMode ChainPoint ChainTip m a
forall header point tip (m :: * -> *) a.
(point -> tip -> ChainSyncClient header point tip m a)
-> (tip -> ChainSyncClient header point tip m a)
-> ClientStIntersect header point tip m a
CS.ClientStIntersect
      ( \ChainPoint
point ChainTip
tip ->
          m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> ChainSyncClient BlockInMode ChainPoint ChainTip m a
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
CS.ChainSyncClient
            (Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> ClientStIdle
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle BlockInMode ChainPoint ChainTip m a
goClientStIdle Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history (ClientStIdle
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClient
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
-> m (ClientStIdle
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
forall header point tip (m :: * -> *) a.
ChainSyncClient header point tip m a
-> m (ClientStIdle header point tip m a)
CS.runChainSyncClient (ChainPoint
-> ChainTip
-> ChainSyncClient
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
recvMsgIntersectFound ChainPoint
point ChainTip
tip))
      )
      ( \ChainTip
tip ->
          m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> ChainSyncClient BlockInMode ChainPoint ChainTip m a
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
CS.ChainSyncClient (Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> ClientStIdle
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle BlockInMode ChainPoint ChainTip m a
goClientStIdle Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history (ClientStIdle
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle BlockInMode ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle BlockInMode ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClient
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
-> m (ClientStIdle
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
forall header point tip (m :: * -> *) a.
ChainSyncClient header point tip m a
-> m (ClientStIdle header point tip m a)
CS.runChainSyncClient (ChainTip
-> ChainSyncClient
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
recvMsgIntersectNotFound ChainTip
tip))
      )

  initialLedgerStateHistory :: History (Either LedgerStateError LedgerStateEvents)
  initialLedgerStateHistory :: History (Either LedgerStateError LedgerStateEvents)
initialLedgerStateHistory = (SlotNo, Either LedgerStateError LedgerStateEvents,
 WithOrigin BlockInMode)
-> History (Either LedgerStateError LedgerStateEvents)
forall a. a -> Seq a
Seq.singleton (SlotNo
0, LedgerStateEvents -> Either LedgerStateError LedgerStateEvents
forall a b. b -> Either a b
Right (LedgerState
ledgerState0, []), WithOrigin BlockInMode
forall t. WithOrigin t
Origin)

-- | See 'chainSyncClientWithLedgerState'.
chainSyncClientPipelinedWithLedgerState
  :: forall m a
   . Monad m
  => Env
  -> LedgerState
  -> ValidationMode
  -> CSP.ChainSyncClientPipelined
      (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent]))
      ChainPoint
      ChainTip
      m
      a
  -> CSP.ChainSyncClientPipelined
      BlockInMode
      ChainPoint
      ChainTip
      m
      a
chainSyncClientPipelinedWithLedgerState :: forall (m :: * -> *) a.
Monad m =>
Env
-> LedgerState
-> ValidationMode
-> ChainSyncClientPipelined
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip m a
chainSyncClientPipelinedWithLedgerState Env
env LedgerState
ledgerState0 ValidationMode
validationMode (CSP.ChainSyncClientPipelined m (ClientPipelinedStIdle
     'Z
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a)
clientTop) =
  m (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip m a)
-> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip m a
forall header point tip (m :: * -> *) a.
m (ClientPipelinedStIdle 'Z header point tip m a)
-> ChainSyncClientPipelined header point tip m a
CSP.ChainSyncClientPipelined
    (Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat 'Z
-> ClientPipelinedStIdle
     'Z
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
goClientPipelinedStIdle (History (Either LedgerStateError LedgerStateEvents)
-> Either
     LedgerStateError
     (History (Either LedgerStateError LedgerStateEvents))
forall a b. b -> Either a b
Right History (Either LedgerStateError LedgerStateEvents)
initialLedgerStateHistory) Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero (ClientPipelinedStIdle
   'Z
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        'Z
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientPipelinedStIdle
     'Z
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a)
clientTop)
 where
  goClientPipelinedStIdle
    :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents))
    -> Nat n
    -> CSP.ClientPipelinedStIdle
        n
        (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a
    -> CSP.ClientPipelinedStIdle
        n
        BlockInMode
        ChainPoint
        ChainTip
        m
        a
  goClientPipelinedStIdle :: forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
goClientPipelinedStIdle Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history Nat n
n ClientPipelinedStIdle
  n
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
client = case ClientPipelinedStIdle
  n
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
client of
    CSP.SendMsgRequestNext m ()
a ClientStNext
  'Z
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
b -> m ()
-> ClientStNext 'Z BlockInMode ChainPoint ChainTip m a
-> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip m a
forall (m :: * -> *) header point tip a.
m ()
-> ClientStNext 'Z header point tip m a
-> ClientPipelinedStIdle 'Z header point tip m a
CSP.SendMsgRequestNext m ()
a (Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat 'Z
-> ClientStNext
     'Z
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext 'Z BlockInMode ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientStNext
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n BlockInMode ChainPoint ChainTip m a
goClientStNext Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history Nat n
Nat 'Z
n ClientStNext
  'Z
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
b)
    CSP.SendMsgRequestNextPipelined m ()
m ClientPipelinedStIdle
  ('S n)
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
a -> m ()
-> ClientPipelinedStIdle ('S n) BlockInMode ChainPoint ChainTip m a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
forall (m :: * -> *) (n :: N) header point tip a.
m ()
-> ClientPipelinedStIdle ('S n) header point tip m a
-> ClientPipelinedStIdle n header point tip m a
CSP.SendMsgRequestNextPipelined m ()
m (Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat ('S n)
-> ClientPipelinedStIdle
     ('S n)
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle ('S n) BlockInMode ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
goClientPipelinedStIdle Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history (Nat n -> Nat ('S n)
forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat n
n) ClientPipelinedStIdle
  ('S n)
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
a)
    CSP.SendMsgFindIntersect [ChainPoint]
ps ClientPipelinedStIntersect
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
a -> [ChainPoint]
-> ClientPipelinedStIntersect BlockInMode ChainPoint ChainTip m a
-> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip m a
forall point header tip (m :: * -> *) a.
[point]
-> ClientPipelinedStIntersect header point tip m a
-> ClientPipelinedStIdle 'Z header point tip m a
CSP.SendMsgFindIntersect [ChainPoint]
ps (Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIntersect
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIntersect BlockInMode ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIntersect
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIntersect BlockInMode ChainPoint ChainTip m a
goClientPipelinedStIntersect Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history Nat n
n ClientPipelinedStIntersect
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
a)
    CSP.CollectResponse Maybe
  (m (ClientPipelinedStIdle
        ('S n1)
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a))
a ClientStNext
  n1
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
b -> case Nat n
n of
      Succ Nat n
nPrev ->
        Maybe
  (m (ClientPipelinedStIdle
        ('S n1) BlockInMode ChainPoint ChainTip m a))
-> ClientStNext n1 BlockInMode ChainPoint ChainTip m a
-> ClientPipelinedStIdle
     ('S n1) BlockInMode ChainPoint ChainTip m a
forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CSP.CollectResponse
          (((m (ClientPipelinedStIdle
      ('S n1)
      (BlockInMode, Either LedgerStateError LedgerStateEvents)
      ChainPoint
      ChainTip
      m
      a)
 -> m (ClientPipelinedStIdle
         ('S n1) BlockInMode ChainPoint ChainTip m a))
-> Maybe
     (m (ClientPipelinedStIdle
           ('S n1)
           (BlockInMode, Either LedgerStateError LedgerStateEvents)
           ChainPoint
           ChainTip
           m
           a))
-> Maybe
     (m (ClientPipelinedStIdle
           ('S n1) BlockInMode ChainPoint ChainTip m a))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((m (ClientPipelinedStIdle
       ('S n1)
       (BlockInMode, Either LedgerStateError LedgerStateEvents)
       ChainPoint
       ChainTip
       m
       a)
  -> m (ClientPipelinedStIdle
          ('S n1) BlockInMode ChainPoint ChainTip m a))
 -> Maybe
      (m (ClientPipelinedStIdle
            ('S n1)
            (BlockInMode, Either LedgerStateError LedgerStateEvents)
            ChainPoint
            ChainTip
            m
            a))
 -> Maybe
      (m (ClientPipelinedStIdle
            ('S n1) BlockInMode ChainPoint ChainTip m a)))
-> ((ClientPipelinedStIdle
       ('S n1)
       (BlockInMode, Either LedgerStateError LedgerStateEvents)
       ChainPoint
       ChainTip
       m
       a
     -> ClientPipelinedStIdle
          ('S n1) BlockInMode ChainPoint ChainTip m a)
    -> m (ClientPipelinedStIdle
            ('S n1)
            (BlockInMode, Either LedgerStateError LedgerStateEvents)
            ChainPoint
            ChainTip
            m
            a)
    -> m (ClientPipelinedStIdle
            ('S n1) BlockInMode ChainPoint ChainTip m a))
-> (ClientPipelinedStIdle
      ('S n1)
      (BlockInMode, Either LedgerStateError LedgerStateEvents)
      ChainPoint
      ChainTip
      m
      a
    -> ClientPipelinedStIdle
         ('S n1) BlockInMode ChainPoint ChainTip m a)
-> Maybe
     (m (ClientPipelinedStIdle
           ('S n1)
           (BlockInMode, Either LedgerStateError LedgerStateEvents)
           ChainPoint
           ChainTip
           m
           a))
-> Maybe
     (m (ClientPipelinedStIdle
           ('S n1) BlockInMode ChainPoint ChainTip m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientPipelinedStIdle
   ('S n1)
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle
      ('S n1) BlockInMode ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        ('S n1)
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle
        ('S n1) BlockInMode ChainPoint ChainTip m a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat ('S n1)
-> ClientPipelinedStIdle
     ('S n1)
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     ('S n1) BlockInMode ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
goClientPipelinedStIdle Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history Nat n
Nat ('S n1)
n) Maybe
  (m (ClientPipelinedStIdle
        ('S n1)
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a))
a)
          (Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n1
-> ClientStNext
     n1
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n1 BlockInMode ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientStNext
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n BlockInMode ChainPoint ChainTip m a
goClientStNext Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history Nat n1
Nat n
nPrev ClientStNext
  n1
  (BlockInMode, Either LedgerStateError LedgerStateEvents)
  ChainPoint
  ChainTip
  m
  a
b)
    CSP.SendMsgDone a
a -> a -> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip m a
forall a header point tip (m :: * -> *).
a -> ClientPipelinedStIdle 'Z header point tip m a
CSP.SendMsgDone a
a

  -- This is where the magic happens. We intercept the blocks and rollbacks
  -- and use it to maintain the correct ledger state.
  goClientStNext
    :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents))
    -> Nat n
    -> CSP.ClientStNext
        n
        (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a
    -> CSP.ClientStNext
        n
        BlockInMode
        ChainPoint
        ChainTip
        m
        a
  goClientStNext :: forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientStNext
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n BlockInMode ChainPoint ChainTip m a
goClientStNext (Left LedgerStateError
err) Nat n
n (CSP.ClientStNext (BlockInMode, Either LedgerStateError LedgerStateEvents)
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollForward ChainPoint
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollBackward) =
    (BlockInMode
 -> ChainTip
 -> m (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a))
-> (ChainPoint
    -> ChainTip
    -> m (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a))
-> ClientStNext n BlockInMode ChainPoint ChainTip m a
forall (n :: N) header point tip (m :: * -> *) a.
(header -> tip -> m (ClientPipelinedStIdle n header point tip m a))
-> (point
    -> tip -> m (ClientPipelinedStIdle n header point tip m a))
-> ClientStNext n header point tip m a
CSP.ClientStNext
      ( \BlockInMode
blkInMode ChainTip
tip ->
          Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
goClientPipelinedStIdle (LedgerStateError
-> Either
     LedgerStateError
     (History (Either LedgerStateError LedgerStateEvents))
forall a b. a -> Either a b
Left LedgerStateError
err) Nat n
n
            (ClientPipelinedStIdle
   n
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        n
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BlockInMode, Either LedgerStateError LedgerStateEvents)
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollForward
              (BlockInMode
blkInMode, LedgerStateError -> Either LedgerStateError LedgerStateEvents
forall a b. a -> Either a b
Left LedgerStateError
err)
              ChainTip
tip
      )
      ( \ChainPoint
point ChainTip
tip ->
          Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
goClientPipelinedStIdle (LedgerStateError
-> Either
     LedgerStateError
     (History (Either LedgerStateError LedgerStateEvents))
forall a b. a -> Either a b
Left LedgerStateError
err) Nat n
n (ClientPipelinedStIdle
   n
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        n
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainPoint
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollBackward ChainPoint
point ChainTip
tip
      )
  goClientStNext (Right History (Either LedgerStateError LedgerStateEvents)
history) Nat n
n (CSP.ClientStNext (BlockInMode, Either LedgerStateError LedgerStateEvents)
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollForward ChainPoint
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollBackward) =
    (BlockInMode
 -> ChainTip
 -> m (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a))
-> (ChainPoint
    -> ChainTip
    -> m (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a))
-> ClientStNext n BlockInMode ChainPoint ChainTip m a
forall (n :: N) header point tip (m :: * -> *) a.
(header -> tip -> m (ClientPipelinedStIdle n header point tip m a))
-> (point
    -> tip -> m (ClientPipelinedStIdle n header point tip m a))
-> ClientStNext n header point tip m a
CSP.ClientStNext
      ( \blkInMode :: BlockInMode
blkInMode@(BlockInMode CardanoEra era
_ (Block (BlockHeader SlotNo
slotNo Hash BlockHeader
_ BlockNo
_) [Tx era]
_)) ChainTip
tip ->
          let
            newLedgerStateE :: Either LedgerStateError LedgerStateEvents
newLedgerStateE = case Int
-> History (Either LedgerStateError LedgerStateEvents)
-> Maybe
     (SlotNo, Either LedgerStateError LedgerStateEvents,
      WithOrigin BlockInMode)
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
0 History (Either LedgerStateError LedgerStateEvents)
history of
              Maybe
  (SlotNo, Either LedgerStateError LedgerStateEvents,
   WithOrigin BlockInMode)
Nothing -> String -> Either LedgerStateError LedgerStateEvents
forall a. HasCallStack => String -> a
error String
"Impossible! History should always be non-empty"
              Just (SlotNo
_, Left LedgerStateError
err, WithOrigin BlockInMode
_) -> LedgerStateError -> Either LedgerStateError LedgerStateEvents
forall a b. a -> Either a b
Left LedgerStateError
err
              Just (SlotNo
_, Right (LedgerState
oldLedgerState, [LedgerEvent]
_), WithOrigin BlockInMode
_) ->
                Env
-> LedgerState
-> ValidationMode
-> BlockInMode
-> Either LedgerStateError LedgerStateEvents
applyBlock
                  Env
env
                  LedgerState
oldLedgerState
                  ValidationMode
validationMode
                  BlockInMode
blkInMode
            (History (Either LedgerStateError LedgerStateEvents)
history', History (Either LedgerStateError LedgerStateEvents)
_) = Env
-> History (Either LedgerStateError LedgerStateEvents)
-> SlotNo
-> Either LedgerStateError LedgerStateEvents
-> BlockInMode
-> (History (Either LedgerStateError LedgerStateEvents),
    History (Either LedgerStateError LedgerStateEvents))
forall a.
Env
-> History a
-> SlotNo
-> a
-> BlockInMode
-> (History a, History a)
pushLedgerState Env
env History (Either LedgerStateError LedgerStateEvents)
history SlotNo
slotNo Either LedgerStateError LedgerStateEvents
newLedgerStateE BlockInMode
blkInMode
           in
            Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
goClientPipelinedStIdle (History (Either LedgerStateError LedgerStateEvents)
-> Either
     LedgerStateError
     (History (Either LedgerStateError LedgerStateEvents))
forall a b. b -> Either a b
Right History (Either LedgerStateError LedgerStateEvents)
history') Nat n
n
              (ClientPipelinedStIdle
   n
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        n
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BlockInMode, Either LedgerStateError LedgerStateEvents)
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollForward
                (BlockInMode
blkInMode, Either LedgerStateError LedgerStateEvents
newLedgerStateE)
                ChainTip
tip
      )
      ( \ChainPoint
point ChainTip
tip ->
          let
            oldestSlot :: SlotNo
oldestSlot = case History (Either LedgerStateError LedgerStateEvents)
history of
              History (Either LedgerStateError LedgerStateEvents)
_ Seq.:|> (SlotNo
s, Either LedgerStateError LedgerStateEvents
_, WithOrigin BlockInMode
_) -> SlotNo
s
              History (Either LedgerStateError LedgerStateEvents)
Seq.Empty -> String -> SlotNo
forall a. HasCallStack => String -> a
error String
"Impossible! History should always be non-empty"
            history' :: Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history' = ( \History (Either LedgerStateError LedgerStateEvents)
h ->
                          if History (Either LedgerStateError LedgerStateEvents) -> Bool
forall a. Seq a -> Bool
Seq.null History (Either LedgerStateError LedgerStateEvents)
h
                            then LedgerStateError
-> Either
     LedgerStateError
     (History (Either LedgerStateError LedgerStateEvents))
forall a b. a -> Either a b
Left (SlotNo -> ChainPoint -> LedgerStateError
InvalidRollback SlotNo
oldestSlot ChainPoint
point)
                            else History (Either LedgerStateError LedgerStateEvents)
-> Either
     LedgerStateError
     (History (Either LedgerStateError LedgerStateEvents))
forall a b. b -> Either a b
Right History (Either LedgerStateError LedgerStateEvents)
h
                       )
              (History (Either LedgerStateError LedgerStateEvents)
 -> Either
      LedgerStateError
      (History (Either LedgerStateError LedgerStateEvents)))
-> History (Either LedgerStateError LedgerStateEvents)
-> Either
     LedgerStateError
     (History (Either LedgerStateError LedgerStateEvents))
forall a b. (a -> b) -> a -> b
$ case ChainPoint
point of
                ChainPoint
ChainPointAtGenesis -> History (Either LedgerStateError LedgerStateEvents)
initialLedgerStateHistory
                ChainPoint SlotNo
slotNo Hash BlockHeader
_ -> History (Either LedgerStateError LedgerStateEvents)
-> SlotNo -> History (Either LedgerStateError LedgerStateEvents)
forall a. History a -> SlotNo -> History a
rollBackLedgerStateHist History (Either LedgerStateError LedgerStateEvents)
history SlotNo
slotNo
           in
            Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
goClientPipelinedStIdle Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history' Nat n
n (ClientPipelinedStIdle
   n
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        n
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainPoint
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollBackward ChainPoint
point ChainTip
tip
      )

  goClientPipelinedStIntersect
    :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents))
    -> Nat n
    -> CSP.ClientPipelinedStIntersect
        (BlockInMode, Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a
    -> CSP.ClientPipelinedStIntersect
        BlockInMode
        ChainPoint
        ChainTip
        m
        a
  goClientPipelinedStIntersect :: forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIntersect
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIntersect BlockInMode ChainPoint ChainTip m a
goClientPipelinedStIntersect Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history Nat n
_ (CSP.ClientPipelinedStIntersect ChainPoint
-> ChainTip
-> m (ClientPipelinedStIdle
        'Z
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
recvMsgIntersectFound ChainTip
-> m (ClientPipelinedStIdle
        'Z
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
recvMsgIntersectNotFound) =
    (ChainPoint
 -> ChainTip
 -> m (ClientPipelinedStIdle
         'Z BlockInMode ChainPoint ChainTip m a))
-> (ChainTip
    -> m (ClientPipelinedStIdle
            'Z BlockInMode ChainPoint ChainTip m a))
-> ClientPipelinedStIntersect BlockInMode ChainPoint ChainTip m a
forall header point tip (m :: * -> *) a.
(point -> tip -> m (ClientPipelinedStIdle 'Z header point tip m a))
-> (tip -> m (ClientPipelinedStIdle 'Z header point tip m a))
-> ClientPipelinedStIntersect header point tip m a
CSP.ClientPipelinedStIntersect
      (\ChainPoint
point ChainTip
tip -> Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat 'Z
-> ClientPipelinedStIdle
     'Z
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
goClientPipelinedStIdle Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero (ClientPipelinedStIdle
   'Z
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        'Z
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainPoint
-> ChainTip
-> m (ClientPipelinedStIdle
        'Z
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
recvMsgIntersectFound ChainPoint
point ChainTip
tip)
      (\ChainTip
tip -> Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat 'Z
-> ClientPipelinedStIdle
     'Z
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode, Either LedgerStateError LedgerStateEvents)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip m a
goClientPipelinedStIdle Either
  LedgerStateError
  (History (Either LedgerStateError LedgerStateEvents))
history Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero (ClientPipelinedStIdle
   'Z
   (BlockInMode, Either LedgerStateError LedgerStateEvents)
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        'Z
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainTip
-> m (ClientPipelinedStIdle
        'Z
        (BlockInMode, Either LedgerStateError LedgerStateEvents)
        ChainPoint
        ChainTip
        m
        a)
recvMsgIntersectNotFound ChainTip
tip)

  initialLedgerStateHistory :: History (Either LedgerStateError LedgerStateEvents)
  initialLedgerStateHistory :: History (Either LedgerStateError LedgerStateEvents)
initialLedgerStateHistory = (SlotNo, Either LedgerStateError LedgerStateEvents,
 WithOrigin BlockInMode)
-> History (Either LedgerStateError LedgerStateEvents)
forall a. a -> Seq a
Seq.singleton (SlotNo
0, LedgerStateEvents -> Either LedgerStateError LedgerStateEvents
forall a b. b -> Either a b
Right (LedgerState
ledgerState0, []), WithOrigin BlockInMode
forall t. WithOrigin t
Origin)

extractHistory
  :: History LedgerStateEvents
  -> [(SlotNo, [LedgerEvent], BlockNo)]
extractHistory :: History LedgerStateEvents -> [(SlotNo, [LedgerEvent], BlockNo)]
extractHistory History LedgerStateEvents
historySeq =
  let histList :: [Item (History LedgerStateEvents)]
histList = History LedgerStateEvents -> [Item (History LedgerStateEvents)]
forall l. IsList l => l -> [Item l]
toList History LedgerStateEvents
historySeq
   in ((SlotNo, LedgerStateEvents, WithOrigin BlockInMode)
 -> (SlotNo, [LedgerEvent], BlockNo))
-> [(SlotNo, LedgerStateEvents, WithOrigin BlockInMode)]
-> [(SlotNo, [LedgerEvent], BlockNo)]
forall a b. (a -> b) -> [a] -> [b]
List.map
        (\(SlotNo
slotNo, (LedgerState
_ledgerState, [LedgerEvent]
ledgerEvents), WithOrigin BlockInMode
block) -> (SlotNo
slotNo, [LedgerEvent]
ledgerEvents, WithOrigin BlockInMode -> BlockNo
getBlockNo WithOrigin BlockInMode
block))
        [(SlotNo, LedgerStateEvents, WithOrigin BlockInMode)]
[Item (History LedgerStateEvents)]
histList

getBlockNo :: WithOrigin BlockInMode -> BlockNo
getBlockNo :: WithOrigin BlockInMode -> BlockNo
getBlockNo = BlockNo
-> (BlockInMode -> BlockNo) -> WithOrigin BlockInMode -> BlockNo
forall b t. b -> (t -> b) -> WithOrigin t -> b
Consensus.withOrigin (Word64 -> BlockNo
BlockNo Word64
0) (CardanoBlock StandardCrypto -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo (CardanoBlock StandardCrypto -> BlockNo)
-> (BlockInMode -> CardanoBlock StandardCrypto)
-> BlockInMode
-> BlockNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockInMode -> CardanoBlock StandardCrypto
forall block.
(CardanoBlock StandardCrypto ~ block) =>
BlockInMode -> block
toConsensusBlock)

{- HLINT ignore chainSyncClientPipelinedWithLedgerState "Use fmap" -}

-- | A history of k (security parameter) recent ledger states. The head is the
-- most recent item. Elements are:
--
-- * Slot number that a new block occurred
-- * The ledger state and events after applying the new block
-- * The new block
type LedgerStateHistory = History LedgerStateEvents

type History a = Seq (SlotNo, a, WithOrigin BlockInMode)

-- | Add a new ledger state to the history
pushLedgerState
  :: Env
  -- ^ Environment used to get the security param, k.
  -> History a
  -- ^ History of k items.
  -> SlotNo
  -- ^ Slot number of the new item.
  -> a
  -- ^ New item to add to the history
  -> BlockInMode
  -- ^ The block that (when applied to the previous
  -- item) resulted in the new item.
  -> (History a, History a)
  -- ^ ( The new history with the new item appended
  --   , Any existing items that are now past the security parameter
  --      and hence can no longer be rolled back.
  --   )
pushLedgerState :: forall a.
Env
-> History a
-> SlotNo
-> a
-> BlockInMode
-> (History a, History a)
pushLedgerState Env
env History a
hist SlotNo
sn a
st BlockInMode
block =
  Int -> History a -> (History a, History a)
forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt
    (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Env -> Word64
envSecurityParam Env
env Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)
    ((SlotNo
sn, a
st, BlockInMode -> WithOrigin BlockInMode
forall t. t -> WithOrigin t
At BlockInMode
block) (SlotNo, a, WithOrigin BlockInMode) -> History a -> History a
forall a. a -> Seq a -> Seq a
Seq.:<| History a
hist)

rollBackLedgerStateHist :: History a -> SlotNo -> History a
rollBackLedgerStateHist :: forall a. History a -> SlotNo -> History a
rollBackLedgerStateHist History a
hist SlotNo
maxInc = ((SlotNo, a, WithOrigin BlockInMode) -> Bool)
-> History a -> History a
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.dropWhileL ((SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
maxInc) (SlotNo -> Bool)
-> ((SlotNo, a, WithOrigin BlockInMode) -> SlotNo)
-> (SlotNo, a, WithOrigin BlockInMode)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(SlotNo
x, a
_, WithOrigin BlockInMode
_) -> SlotNo
x)) History a
hist

--------------------------------------------------------------------------------
-- Everything below was copied/adapted from db-sync                           --
--------------------------------------------------------------------------------

genesisConfigToEnv
  :: GenesisConfig
  -> Either GenesisConfigError Env
genesisConfigToEnv :: GenesisConfig -> Either GenesisConfigError Env
genesisConfigToEnv
  -- enp
  GenesisConfig
genCfg =
    case GenesisConfig
genCfg of
      GenesisCardano NodeConfig
_ Config
bCfg GenesisHashShelley
_ TransitionConfig (LatestKnownEra StandardCrypto)
transCfg
        | ProtocolMagicId -> Word32
Cardano.Crypto.ProtocolMagic.unProtocolMagicId (Config -> ProtocolMagicId
Cardano.Chain.Genesis.configProtocolMagicId Config
bCfg)
            Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= ShelleyGenesis StandardCrypto -> Word32
forall c. ShelleyGenesis c -> Word32
Ledger.sgNetworkMagic ShelleyGenesis StandardCrypto
shelleyGenesis ->
            GenesisConfigError -> Either GenesisConfigError Env
forall a b. a -> Either a b
Left (GenesisConfigError -> Either GenesisConfigError Env)
-> (Text -> GenesisConfigError)
-> Text
-> Either GenesisConfigError Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> GenesisConfigError
NECardanoConfig (Text -> Either GenesisConfigError Env)
-> Text -> Either GenesisConfigError Env
forall a b. (a -> b) -> a -> b
$
              [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
"ProtocolMagicId "
                , Word32 -> Text
forall a. Show a => a -> Text
textShow
                    (ProtocolMagicId -> Word32
Cardano.Crypto.ProtocolMagic.unProtocolMagicId (ProtocolMagicId -> Word32) -> ProtocolMagicId -> Word32
forall a b. (a -> b) -> a -> b
$ Config -> ProtocolMagicId
Cardano.Chain.Genesis.configProtocolMagicId Config
bCfg)
                , Text
" /= "
                , Word32 -> Text
forall a. Show a => a -> Text
textShow (ShelleyGenesis StandardCrypto -> Word32
forall c. ShelleyGenesis c -> Word32
Ledger.sgNetworkMagic ShelleyGenesis StandardCrypto
shelleyGenesis)
                ]
        | GenesisData -> UTCTime
Cardano.Chain.Genesis.gdStartTime (Config -> GenesisData
Cardano.Chain.Genesis.configGenesisData Config
bCfg)
            UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
/= ShelleyGenesis StandardCrypto -> UTCTime
forall c. ShelleyGenesis c -> UTCTime
Ledger.sgSystemStart ShelleyGenesis StandardCrypto
shelleyGenesis ->
            GenesisConfigError -> Either GenesisConfigError Env
forall a b. a -> Either a b
Left (GenesisConfigError -> Either GenesisConfigError Env)
-> (Text -> GenesisConfigError)
-> Text
-> Either GenesisConfigError Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> GenesisConfigError
NECardanoConfig (Text -> Either GenesisConfigError Env)
-> Text -> Either GenesisConfigError Env
forall a b. (a -> b) -> a -> b
$
              [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
"SystemStart "
                , UTCTime -> Text
forall a. Show a => a -> Text
textShow (GenesisData -> UTCTime
Cardano.Chain.Genesis.gdStartTime (GenesisData -> UTCTime) -> GenesisData -> UTCTime
forall a b. (a -> b) -> a -> b
$ Config -> GenesisData
Cardano.Chain.Genesis.configGenesisData Config
bCfg)
                , Text
" /= "
                , UTCTime -> Text
forall a. Show a => a -> Text
textShow (ShelleyGenesis StandardCrypto -> UTCTime
forall c. ShelleyGenesis c -> UTCTime
Ledger.sgSystemStart ShelleyGenesis StandardCrypto
shelleyGenesis)
                ]
        | Bool
otherwise ->
            let
              topLevelConfig :: TopLevelConfig (CardanoBlock StandardCrypto)
topLevelConfig = ProtocolInfo (CardanoBlock StandardCrypto)
-> TopLevelConfig (CardanoBlock StandardCrypto)
forall b. ProtocolInfo b -> TopLevelConfig b
Consensus.pInfoConfig (ProtocolInfo (CardanoBlock StandardCrypto)
 -> TopLevelConfig (CardanoBlock StandardCrypto))
-> ProtocolInfo (CardanoBlock StandardCrypto)
-> TopLevelConfig (CardanoBlock StandardCrypto)
forall a b. (a -> b) -> a -> b
$ (ProtocolInfo (CardanoBlock StandardCrypto),
 IO [BlockForging IO (CardanoBlock StandardCrypto)])
-> ProtocolInfo (CardanoBlock StandardCrypto)
forall a b. (a, b) -> a
fst ((ProtocolInfo (CardanoBlock StandardCrypto),
  IO [BlockForging IO (CardanoBlock StandardCrypto)])
 -> ProtocolInfo (CardanoBlock StandardCrypto))
-> (ProtocolInfo (CardanoBlock StandardCrypto),
    IO [BlockForging IO (CardanoBlock StandardCrypto)])
-> ProtocolInfo (CardanoBlock StandardCrypto)
forall a b. (a -> b) -> a -> b
$ GenesisConfig
-> (ProtocolInfo (CardanoBlock StandardCrypto),
    IO [BlockForging IO (CardanoBlock StandardCrypto)])
mkProtocolInfoCardano GenesisConfig
genCfg
             in
              Env -> Either GenesisConfigError Env
forall a b. b -> Either a b
Right (Env -> Either GenesisConfigError Env)
-> Env -> Either GenesisConfigError Env
forall a b. (a -> b) -> a -> b
$
                Env
                  { envLedgerConfig :: CardanoLedgerConfig StandardCrypto
envLedgerConfig = TopLevelConfig (CardanoBlock StandardCrypto)
-> LedgerConfig (CardanoBlock StandardCrypto)
forall blk. TopLevelConfig blk -> LedgerConfig blk
Consensus.topLevelConfigLedger TopLevelConfig (CardanoBlock StandardCrypto)
topLevelConfig
                  , envConsensusConfig :: CardanoConsensusConfig StandardCrypto
envConsensusConfig = TopLevelConfig (CardanoBlock StandardCrypto)
-> ConsensusConfig (BlockProtocol (CardanoBlock StandardCrypto))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
Consensus.topLevelConfigProtocol TopLevelConfig (CardanoBlock StandardCrypto)
topLevelConfig
                  }
       where
        shelleyGenesis :: ShelleyGenesis StandardCrypto
shelleyGenesis = TransitionConfig (LatestKnownEra StandardCrypto)
transCfg TransitionConfig (LatestKnownEra StandardCrypto)
-> Getting
     (ShelleyGenesis StandardCrypto)
     (TransitionConfig (LatestKnownEra StandardCrypto))
     (ShelleyGenesis StandardCrypto)
-> ShelleyGenesis StandardCrypto
forall s a. s -> Getting a s a -> a
^. (ShelleyGenesis (EraCrypto (LatestKnownEra StandardCrypto))
 -> Const
      (ShelleyGenesis StandardCrypto)
      (ShelleyGenesis (EraCrypto (LatestKnownEra StandardCrypto))))
-> TransitionConfig (LatestKnownEra StandardCrypto)
-> Const
     (ShelleyGenesis StandardCrypto)
     (TransitionConfig (LatestKnownEra StandardCrypto))
Getting
  (ShelleyGenesis StandardCrypto)
  (TransitionConfig (LatestKnownEra StandardCrypto))
  (ShelleyGenesis StandardCrypto)
forall era.
EraTransition era =>
Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
Lens'
  (TransitionConfig (LatestKnownEra StandardCrypto))
  (ShelleyGenesis (EraCrypto (LatestKnownEra StandardCrypto)))
Ledger.tcShelleyGenesisL

readNodeConfig
  :: MonadError Text m
  => MonadIO m
  => NodeConfigFile 'In
  -> m NodeConfig
readNodeConfig :: forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
NodeConfigFile 'In -> m NodeConfig
readNodeConfig (File String
ncf) = do
  NodeConfig
ncfg <- Either Text NodeConfig -> m NodeConfig
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Text NodeConfig -> m NodeConfig)
-> (ByteString -> Either Text NodeConfig)
-> ByteString
-> m NodeConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text NodeConfig
parseNodeConfig (ByteString -> m NodeConfig) -> m ByteString -> m NodeConfig
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Text -> m ByteString
forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
String -> Text -> m ByteString
readByteString String
ncf Text
"node"
  NodeConfig -> m NodeConfig
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    NodeConfig
ncfg
      { ncByronGenesisFile =
          mapFile (mkAdjustPath ncf) (ncByronGenesisFile ncfg)
      , ncShelleyGenesisFile =
          mapFile (mkAdjustPath ncf) (ncShelleyGenesisFile ncfg)
      , ncAlonzoGenesisFile =
          mapFile (mkAdjustPath ncf) (ncAlonzoGenesisFile ncfg)
      , ncConwayGenesisFile =
          mapFile (mkAdjustPath ncf) <$> ncConwayGenesisFile ncfg
      }

data NodeConfig = NodeConfig
  { NodeConfig -> Maybe Double
ncPBftSignatureThreshold :: !(Maybe Double)
  , NodeConfig -> File Config 'In
ncByronGenesisFile :: !(File ByronGenesisConfig 'In)
  , NodeConfig -> GenesisHashByron
ncByronGenesisHash :: !GenesisHashByron
  , NodeConfig -> File ShelleyGenesisConfig 'In
ncShelleyGenesisFile :: !(File ShelleyGenesisConfig 'In)
  , NodeConfig -> GenesisHashShelley
ncShelleyGenesisHash :: !GenesisHashShelley
  , NodeConfig -> File AlonzoGenesis 'In
ncAlonzoGenesisFile :: !(File AlonzoGenesis 'In)
  , NodeConfig -> GenesisHashAlonzo
ncAlonzoGenesisHash :: !GenesisHashAlonzo
  , NodeConfig -> Maybe (File ConwayGenesisConfig 'In)
ncConwayGenesisFile :: !(Maybe (File ConwayGenesisConfig 'In))
  , NodeConfig -> Maybe GenesisHashConway
ncConwayGenesisHash :: !(Maybe GenesisHashConway)
  , NodeConfig -> RequiresNetworkMagic
ncRequiresNetworkMagic :: !Cardano.Crypto.RequiresNetworkMagic
  , NodeConfig -> ProtocolVersion
ncByronProtocolVersion :: !Cardano.Chain.Update.ProtocolVersion
  , NodeConfig -> CardanoHardForkTriggers
ncHardForkTriggers :: !Consensus.CardanoHardForkTriggers
  }

instance FromJSON NodeConfig where
  parseJSON :: Value -> Parser NodeConfig
parseJSON =
    String
-> (Object -> Parser NodeConfig) -> Value -> Parser NodeConfig
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"NodeConfig" Object -> Parser NodeConfig
parse
   where
    parse :: Object -> Parser NodeConfig
    parse :: Object -> Parser NodeConfig
parse Object
o =
      Maybe Double
-> File Config 'In
-> GenesisHashByron
-> File ShelleyGenesisConfig 'In
-> GenesisHashShelley
-> File AlonzoGenesis 'In
-> GenesisHashAlonzo
-> Maybe (File ConwayGenesisConfig 'In)
-> Maybe GenesisHashConway
-> RequiresNetworkMagic
-> ProtocolVersion
-> CardanoHardForkTriggers
-> NodeConfig
NodeConfig
        (Maybe Double
 -> File Config 'In
 -> GenesisHashByron
 -> File ShelleyGenesisConfig 'In
 -> GenesisHashShelley
 -> File AlonzoGenesis 'In
 -> GenesisHashAlonzo
 -> Maybe (File ConwayGenesisConfig 'In)
 -> Maybe GenesisHashConway
 -> RequiresNetworkMagic
 -> ProtocolVersion
 -> CardanoHardForkTriggers
 -> NodeConfig)
-> Parser (Maybe Double)
-> Parser
     (File Config 'In
      -> GenesisHashByron
      -> File ShelleyGenesisConfig 'In
      -> GenesisHashShelley
      -> File AlonzoGenesis 'In
      -> GenesisHashAlonzo
      -> Maybe (File ConwayGenesisConfig 'In)
      -> Maybe GenesisHashConway
      -> RequiresNetworkMagic
      -> ProtocolVersion
      -> CardanoHardForkTriggers
      -> NodeConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe Double)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"PBftSignatureThreshold"
        Parser
  (File Config 'In
   -> GenesisHashByron
   -> File ShelleyGenesisConfig 'In
   -> GenesisHashShelley
   -> File AlonzoGenesis 'In
   -> GenesisHashAlonzo
   -> Maybe (File ConwayGenesisConfig 'In)
   -> Maybe GenesisHashConway
   -> RequiresNetworkMagic
   -> ProtocolVersion
   -> CardanoHardForkTriggers
   -> NodeConfig)
-> Parser (File Config 'In)
-> Parser
     (GenesisHashByron
      -> File ShelleyGenesisConfig 'In
      -> GenesisHashShelley
      -> File AlonzoGenesis 'In
      -> GenesisHashAlonzo
      -> Maybe (File ConwayGenesisConfig 'In)
      -> Maybe GenesisHashConway
      -> RequiresNetworkMagic
      -> ProtocolVersion
      -> CardanoHardForkTriggers
      -> NodeConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> File Config 'In)
-> Parser String -> Parser (File Config 'In)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> File Config 'In
forall content (direction :: FileDirection).
String -> File content direction
File (Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"ByronGenesisFile")
        Parser
  (GenesisHashByron
   -> File ShelleyGenesisConfig 'In
   -> GenesisHashShelley
   -> File AlonzoGenesis 'In
   -> GenesisHashAlonzo
   -> Maybe (File ConwayGenesisConfig 'In)
   -> Maybe GenesisHashConway
   -> RequiresNetworkMagic
   -> ProtocolVersion
   -> CardanoHardForkTriggers
   -> NodeConfig)
-> Parser GenesisHashByron
-> Parser
     (File ShelleyGenesisConfig 'In
      -> GenesisHashShelley
      -> File AlonzoGenesis 'In
      -> GenesisHashAlonzo
      -> Maybe (File ConwayGenesisConfig 'In)
      -> Maybe GenesisHashConway
      -> RequiresNetworkMagic
      -> ProtocolVersion
      -> CardanoHardForkTriggers
      -> NodeConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> GenesisHashByron)
-> Parser Text -> Parser GenesisHashByron
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> GenesisHashByron
GenesisHashByron (Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"ByronGenesisHash")
        Parser
  (File ShelleyGenesisConfig 'In
   -> GenesisHashShelley
   -> File AlonzoGenesis 'In
   -> GenesisHashAlonzo
   -> Maybe (File ConwayGenesisConfig 'In)
   -> Maybe GenesisHashConway
   -> RequiresNetworkMagic
   -> ProtocolVersion
   -> CardanoHardForkTriggers
   -> NodeConfig)
-> Parser (File ShelleyGenesisConfig 'In)
-> Parser
     (GenesisHashShelley
      -> File AlonzoGenesis 'In
      -> GenesisHashAlonzo
      -> Maybe (File ConwayGenesisConfig 'In)
      -> Maybe GenesisHashConway
      -> RequiresNetworkMagic
      -> ProtocolVersion
      -> CardanoHardForkTriggers
      -> NodeConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> File ShelleyGenesisConfig 'In)
-> Parser String -> Parser (File ShelleyGenesisConfig 'In)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> File ShelleyGenesisConfig 'In
forall content (direction :: FileDirection).
String -> File content direction
File (Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"ShelleyGenesisFile")
        Parser
  (GenesisHashShelley
   -> File AlonzoGenesis 'In
   -> GenesisHashAlonzo
   -> Maybe (File ConwayGenesisConfig 'In)
   -> Maybe GenesisHashConway
   -> RequiresNetworkMagic
   -> ProtocolVersion
   -> CardanoHardForkTriggers
   -> NodeConfig)
-> Parser GenesisHashShelley
-> Parser
     (File AlonzoGenesis 'In
      -> GenesisHashAlonzo
      -> Maybe (File ConwayGenesisConfig 'In)
      -> Maybe GenesisHashConway
      -> RequiresNetworkMagic
      -> ProtocolVersion
      -> CardanoHardForkTriggers
      -> NodeConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Hash Blake2b_256 ByteString -> GenesisHashShelley)
-> Parser (Hash Blake2b_256 ByteString)
-> Parser GenesisHashShelley
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Hash Blake2b_256 ByteString -> GenesisHashShelley
GenesisHashShelley (Object
o Object -> Key -> Parser (Hash Blake2b_256 ByteString)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"ShelleyGenesisHash")
        Parser
  (File AlonzoGenesis 'In
   -> GenesisHashAlonzo
   -> Maybe (File ConwayGenesisConfig 'In)
   -> Maybe GenesisHashConway
   -> RequiresNetworkMagic
   -> ProtocolVersion
   -> CardanoHardForkTriggers
   -> NodeConfig)
-> Parser (File AlonzoGenesis 'In)
-> Parser
     (GenesisHashAlonzo
      -> Maybe (File ConwayGenesisConfig 'In)
      -> Maybe GenesisHashConway
      -> RequiresNetworkMagic
      -> ProtocolVersion
      -> CardanoHardForkTriggers
      -> NodeConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> File AlonzoGenesis 'In)
-> Parser String -> Parser (File AlonzoGenesis 'In)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> File AlonzoGenesis 'In
forall content (direction :: FileDirection).
String -> File content direction
File (Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"AlonzoGenesisFile")
        Parser
  (GenesisHashAlonzo
   -> Maybe (File ConwayGenesisConfig 'In)
   -> Maybe GenesisHashConway
   -> RequiresNetworkMagic
   -> ProtocolVersion
   -> CardanoHardForkTriggers
   -> NodeConfig)
-> Parser GenesisHashAlonzo
-> Parser
     (Maybe (File ConwayGenesisConfig 'In)
      -> Maybe GenesisHashConway
      -> RequiresNetworkMagic
      -> ProtocolVersion
      -> CardanoHardForkTriggers
      -> NodeConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Hash Blake2b_256 ByteString -> GenesisHashAlonzo)
-> Parser (Hash Blake2b_256 ByteString) -> Parser GenesisHashAlonzo
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Hash Blake2b_256 ByteString -> GenesisHashAlonzo
GenesisHashAlonzo (Object
o Object -> Key -> Parser (Hash Blake2b_256 ByteString)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"AlonzoGenesisHash")
        Parser
  (Maybe (File ConwayGenesisConfig 'In)
   -> Maybe GenesisHashConway
   -> RequiresNetworkMagic
   -> ProtocolVersion
   -> CardanoHardForkTriggers
   -> NodeConfig)
-> Parser (Maybe (File ConwayGenesisConfig 'In))
-> Parser
     (Maybe GenesisHashConway
      -> RequiresNetworkMagic
      -> ProtocolVersion
      -> CardanoHardForkTriggers
      -> NodeConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Maybe String -> Maybe (File ConwayGenesisConfig 'In))
-> Parser (Maybe String)
-> Parser (Maybe (File ConwayGenesisConfig 'In))
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe String -> Maybe (File ConwayGenesisConfig 'In))
 -> Parser (Maybe String)
 -> Parser (Maybe (File ConwayGenesisConfig 'In)))
-> ((String -> File ConwayGenesisConfig 'In)
    -> Maybe String -> Maybe (File ConwayGenesisConfig 'In))
-> (String -> File ConwayGenesisConfig 'In)
-> Parser (Maybe String)
-> Parser (Maybe (File ConwayGenesisConfig 'In))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> File ConwayGenesisConfig 'In)
-> Maybe String -> Maybe (File ConwayGenesisConfig 'In)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) String -> File ConwayGenesisConfig 'In
forall content (direction :: FileDirection).
String -> File content direction
File (Object
o Object -> Key -> Parser (Maybe String)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"ConwayGenesisFile")
        Parser
  (Maybe GenesisHashConway
   -> RequiresNetworkMagic
   -> ProtocolVersion
   -> CardanoHardForkTriggers
   -> NodeConfig)
-> Parser (Maybe GenesisHashConway)
-> Parser
     (RequiresNetworkMagic
      -> ProtocolVersion -> CardanoHardForkTriggers -> NodeConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Maybe (Hash Blake2b_256 ByteString) -> Maybe GenesisHashConway)
-> Parser (Maybe (Hash Blake2b_256 ByteString))
-> Parser (Maybe GenesisHashConway)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe (Hash Blake2b_256 ByteString) -> Maybe GenesisHashConway)
 -> Parser (Maybe (Hash Blake2b_256 ByteString))
 -> Parser (Maybe GenesisHashConway))
-> ((Hash Blake2b_256 ByteString -> GenesisHashConway)
    -> Maybe (Hash Blake2b_256 ByteString) -> Maybe GenesisHashConway)
-> (Hash Blake2b_256 ByteString -> GenesisHashConway)
-> Parser (Maybe (Hash Blake2b_256 ByteString))
-> Parser (Maybe GenesisHashConway)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Hash Blake2b_256 ByteString -> GenesisHashConway)
-> Maybe (Hash Blake2b_256 ByteString) -> Maybe GenesisHashConway
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Hash Blake2b_256 ByteString -> GenesisHashConway
GenesisHashConway (Object
o Object -> Key -> Parser (Maybe (Hash Blake2b_256 ByteString))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"ConwayGenesisHash")
        Parser
  (RequiresNetworkMagic
   -> ProtocolVersion -> CardanoHardForkTriggers -> NodeConfig)
-> Parser RequiresNetworkMagic
-> Parser
     (ProtocolVersion -> CardanoHardForkTriggers -> NodeConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser RequiresNetworkMagic
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"RequiresNetworkMagic"
        Parser (ProtocolVersion -> CardanoHardForkTriggers -> NodeConfig)
-> Parser ProtocolVersion
-> Parser (CardanoHardForkTriggers -> NodeConfig)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser ProtocolVersion
parseByronProtocolVersion Object
o
        Parser (CardanoHardForkTriggers -> NodeConfig)
-> Parser CardanoHardForkTriggers -> Parser NodeConfig
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser CardanoHardForkTriggers
parseHardForkTriggers Object
o

    parseByronProtocolVersion :: Object -> Parser Cardano.Chain.Update.ProtocolVersion
    parseByronProtocolVersion :: Object -> Parser ProtocolVersion
parseByronProtocolVersion Object
o =
      Word16 -> Word16 -> Word8 -> ProtocolVersion
Cardano.Chain.Update.ProtocolVersion
        (Word16 -> Word16 -> Word8 -> ProtocolVersion)
-> Parser Word16 -> Parser (Word16 -> Word8 -> ProtocolVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Word16
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"LastKnownBlockVersion-Major"
        Parser (Word16 -> Word8 -> ProtocolVersion)
-> Parser Word16 -> Parser (Word8 -> ProtocolVersion)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Word16
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"LastKnownBlockVersion-Minor"
        Parser (Word8 -> ProtocolVersion)
-> Parser Word8 -> Parser ProtocolVersion
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Word8
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"LastKnownBlockVersion-Alt"

    parseHardForkTriggers :: Object -> Parser Consensus.CardanoHardForkTriggers
    parseHardForkTriggers :: Object -> Parser CardanoHardForkTriggers
parseHardForkTriggers Object
o =
      TriggerHardFork
-> TriggerHardFork
-> TriggerHardFork
-> TriggerHardFork
-> TriggerHardFork
-> TriggerHardFork
-> CardanoHardForkTriggers
Consensus.CardanoHardForkTriggers'
        (TriggerHardFork
 -> TriggerHardFork
 -> TriggerHardFork
 -> TriggerHardFork
 -> TriggerHardFork
 -> TriggerHardFork
 -> CardanoHardForkTriggers)
-> Parser TriggerHardFork
-> Parser
     (TriggerHardFork
      -> TriggerHardFork
      -> TriggerHardFork
      -> TriggerHardFork
      -> TriggerHardFork
      -> CardanoHardForkTriggers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser TriggerHardFork
parseShelleyHardForkEpoch Object
o
        Parser
  (TriggerHardFork
   -> TriggerHardFork
   -> TriggerHardFork
   -> TriggerHardFork
   -> TriggerHardFork
   -> CardanoHardForkTriggers)
-> Parser TriggerHardFork
-> Parser
     (TriggerHardFork
      -> TriggerHardFork
      -> TriggerHardFork
      -> TriggerHardFork
      -> CardanoHardForkTriggers)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser TriggerHardFork
parseAllegraHardForkEpoch Object
o
        Parser
  (TriggerHardFork
   -> TriggerHardFork
   -> TriggerHardFork
   -> TriggerHardFork
   -> CardanoHardForkTriggers)
-> Parser TriggerHardFork
-> Parser
     (TriggerHardFork
      -> TriggerHardFork -> TriggerHardFork -> CardanoHardForkTriggers)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser TriggerHardFork
parseMaryHardForkEpoch Object
o
        Parser
  (TriggerHardFork
   -> TriggerHardFork -> TriggerHardFork -> CardanoHardForkTriggers)
-> Parser TriggerHardFork
-> Parser
     (TriggerHardFork -> TriggerHardFork -> CardanoHardForkTriggers)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser TriggerHardFork
parseAlonzoHardForkEpoch Object
o
        Parser
  (TriggerHardFork -> TriggerHardFork -> CardanoHardForkTriggers)
-> Parser TriggerHardFork
-> Parser (TriggerHardFork -> CardanoHardForkTriggers)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser TriggerHardFork
parseBabbageHardForkEpoch Object
o
        Parser (TriggerHardFork -> CardanoHardForkTriggers)
-> Parser TriggerHardFork -> Parser CardanoHardForkTriggers
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser TriggerHardFork
parseConwayHardForkEpoch Object
o

    parseShelleyHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork
    parseShelleyHardForkEpoch :: Object -> Parser TriggerHardFork
parseShelleyHardForkEpoch Object
o =
      [Parser TriggerHardFork] -> Parser TriggerHardFork
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ EpochNo -> TriggerHardFork
Consensus.TriggerHardForkAtEpoch (EpochNo -> TriggerHardFork)
-> Parser EpochNo -> Parser TriggerHardFork
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser EpochNo
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"TestShelleyHardForkAtEpoch"
        , TriggerHardFork -> Parser TriggerHardFork
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TriggerHardFork -> Parser TriggerHardFork)
-> TriggerHardFork -> Parser TriggerHardFork
forall a b. (a -> b) -> a -> b
$ Word16 -> TriggerHardFork
Consensus.TriggerHardForkAtVersion Word16
2 -- Mainnet default
        ]

    parseAllegraHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork
    parseAllegraHardForkEpoch :: Object -> Parser TriggerHardFork
parseAllegraHardForkEpoch Object
o =
      [Parser TriggerHardFork] -> Parser TriggerHardFork
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ EpochNo -> TriggerHardFork
Consensus.TriggerHardForkAtEpoch (EpochNo -> TriggerHardFork)
-> Parser EpochNo -> Parser TriggerHardFork
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser EpochNo
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"TestAllegraHardForkAtEpoch"
        , TriggerHardFork -> Parser TriggerHardFork
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TriggerHardFork -> Parser TriggerHardFork)
-> TriggerHardFork -> Parser TriggerHardFork
forall a b. (a -> b) -> a -> b
$ Word16 -> TriggerHardFork
Consensus.TriggerHardForkAtVersion Word16
3 -- Mainnet default
        ]

    parseMaryHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork
    parseMaryHardForkEpoch :: Object -> Parser TriggerHardFork
parseMaryHardForkEpoch Object
o =
      [Parser TriggerHardFork] -> Parser TriggerHardFork
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ EpochNo -> TriggerHardFork
Consensus.TriggerHardForkAtEpoch (EpochNo -> TriggerHardFork)
-> Parser EpochNo -> Parser TriggerHardFork
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser EpochNo
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"TestMaryHardForkAtEpoch"
        , TriggerHardFork -> Parser TriggerHardFork
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TriggerHardFork -> Parser TriggerHardFork)
-> TriggerHardFork -> Parser TriggerHardFork
forall a b. (a -> b) -> a -> b
$ Word16 -> TriggerHardFork
Consensus.TriggerHardForkAtVersion Word16
4 -- Mainnet default
        ]

    parseAlonzoHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork
    parseAlonzoHardForkEpoch :: Object -> Parser TriggerHardFork
parseAlonzoHardForkEpoch Object
o =
      [Parser TriggerHardFork] -> Parser TriggerHardFork
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ EpochNo -> TriggerHardFork
Consensus.TriggerHardForkAtEpoch (EpochNo -> TriggerHardFork)
-> Parser EpochNo -> Parser TriggerHardFork
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser EpochNo
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"TestAlonzoHardForkAtEpoch"
        , TriggerHardFork -> Parser TriggerHardFork
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TriggerHardFork -> Parser TriggerHardFork)
-> TriggerHardFork -> Parser TriggerHardFork
forall a b. (a -> b) -> a -> b
$ Word16 -> TriggerHardFork
Consensus.TriggerHardForkAtVersion Word16
5 -- Mainnet default
        ]
    parseBabbageHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork
    parseBabbageHardForkEpoch :: Object -> Parser TriggerHardFork
parseBabbageHardForkEpoch Object
o =
      [Parser TriggerHardFork] -> Parser TriggerHardFork
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ EpochNo -> TriggerHardFork
Consensus.TriggerHardForkAtEpoch (EpochNo -> TriggerHardFork)
-> Parser EpochNo -> Parser TriggerHardFork
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser EpochNo
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"TestBabbageHardForkAtEpoch"
        , TriggerHardFork -> Parser TriggerHardFork
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TriggerHardFork -> Parser TriggerHardFork)
-> TriggerHardFork -> Parser TriggerHardFork
forall a b. (a -> b) -> a -> b
$ Word16 -> TriggerHardFork
Consensus.TriggerHardForkAtVersion Word16
7 -- Mainnet default
        ]

    parseConwayHardForkEpoch :: Object -> Parser Consensus.TriggerHardFork
    parseConwayHardForkEpoch :: Object -> Parser TriggerHardFork
parseConwayHardForkEpoch Object
o =
      [Parser TriggerHardFork] -> Parser TriggerHardFork
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ EpochNo -> TriggerHardFork
Consensus.TriggerHardForkAtEpoch (EpochNo -> TriggerHardFork)
-> Parser EpochNo -> Parser TriggerHardFork
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser EpochNo
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"TestConwayHardForkAtEpoch"
        , TriggerHardFork -> Parser TriggerHardFork
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TriggerHardFork -> Parser TriggerHardFork)
-> TriggerHardFork -> Parser TriggerHardFork
forall a b. (a -> b) -> a -> b
$ Word16 -> TriggerHardFork
Consensus.TriggerHardForkAtVersion Word16
9 -- Mainnet default
        ]

----------------------------------------------------------------------
-- WARNING When adding new entries above, be aware that if there is an
-- intra-era fork, then the numbering is not consecutive.
----------------------------------------------------------------------

parseNodeConfig :: ByteString -> Either Text NodeConfig
parseNodeConfig :: ByteString -> Either Text NodeConfig
parseNodeConfig ByteString
bs =
  case ByteString -> Either ParseException NodeConfig
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' ByteString
bs of
    Left ParseException
err -> Text -> Either Text NodeConfig
forall a b. a -> Either a b
Left (Text -> Either Text NodeConfig) -> Text -> Either Text NodeConfig
forall a b. (a -> b) -> a -> b
$ Text
"Error parsing node config: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseException -> Text
forall a. Show a => a -> Text
textShow ParseException
err
    Right NodeConfig
nc -> NodeConfig -> Either Text NodeConfig
forall a b. b -> Either a b
Right NodeConfig
nc

mkAdjustPath :: FilePath -> (FilePath -> FilePath)
mkAdjustPath :: String -> ShowS
mkAdjustPath String
nodeConfigFilePath String
fp = ShowS
takeDirectory String
nodeConfigFilePath String -> ShowS
</> String
fp

readByteString
  :: MonadError Text m
  => MonadIO m
  => FilePath
  -> Text
  -> m ByteString
readByteString :: forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
String -> Text -> m ByteString
readByteString String
fp Text
cfgType = (Either Text ByteString -> m ByteString
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Text ByteString -> m ByteString)
-> (IO (Either Text ByteString) -> m (Either Text ByteString))
-> IO (Either Text ByteString)
-> m ByteString
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either Text ByteString) -> m (Either Text ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO) (IO (Either Text ByteString) -> m ByteString)
-> IO (Either Text ByteString) -> m ByteString
forall a b. (a -> b) -> a -> b
$
  IO (Either Text ByteString)
-> (IOException -> IO (Either Text ByteString))
-> IO (Either Text ByteString)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right (ByteString -> Either Text ByteString)
-> IO ByteString -> IO (Either Text ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
fp) ((IOException -> IO (Either Text ByteString))
 -> IO (Either Text ByteString))
-> (IOException -> IO (Either Text ByteString))
-> IO (Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ \(IOException
_ :: IOException) ->
    Either Text ByteString -> IO (Either Text ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text ByteString -> IO (Either Text ByteString))
-> Either Text ByteString -> IO (Either Text ByteString)
forall a b. (a -> b) -> a -> b
$
      Text -> Either Text ByteString
forall a b. a -> Either a b
Left (Text -> Either Text ByteString) -> Text -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$
        [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
          [Text
"Cannot read the ", Text
cfgType, Text
" configuration file at : ", String -> Text
Text.pack String
fp]

initLedgerStateVar :: GenesisConfig -> LedgerState
initLedgerStateVar :: GenesisConfig -> LedgerState
initLedgerStateVar GenesisConfig
genesisConfig =
  LedgerState
    { clsState :: CardanoLedgerState StandardCrypto
clsState = ExtLedgerState (CardanoBlock StandardCrypto)
-> CardanoLedgerState StandardCrypto
forall blk. ExtLedgerState blk -> LedgerState blk
Ledger.ledgerState (ExtLedgerState (CardanoBlock StandardCrypto)
 -> CardanoLedgerState StandardCrypto)
-> ExtLedgerState (CardanoBlock StandardCrypto)
-> CardanoLedgerState StandardCrypto
forall a b. (a -> b) -> a -> b
$ ProtocolInfo (CardanoBlock StandardCrypto)
-> ExtLedgerState (CardanoBlock StandardCrypto)
forall b. ProtocolInfo b -> ExtLedgerState b
Consensus.pInfoInitLedger (ProtocolInfo (CardanoBlock StandardCrypto)
 -> ExtLedgerState (CardanoBlock StandardCrypto))
-> ProtocolInfo (CardanoBlock StandardCrypto)
-> ExtLedgerState (CardanoBlock StandardCrypto)
forall a b. (a -> b) -> a -> b
$ (ProtocolInfo (CardanoBlock StandardCrypto),
 IO [BlockForging IO (CardanoBlock StandardCrypto)])
-> ProtocolInfo (CardanoBlock StandardCrypto)
forall a b. (a, b) -> a
fst (ProtocolInfo (CardanoBlock StandardCrypto),
 IO [BlockForging IO (CardanoBlock StandardCrypto)])
protocolInfo
    }
 where
  protocolInfo :: (ProtocolInfo (CardanoBlock StandardCrypto),
 IO [BlockForging IO (CardanoBlock StandardCrypto)])
protocolInfo = GenesisConfig
-> (ProtocolInfo (CardanoBlock StandardCrypto),
    IO [BlockForging IO (CardanoBlock StandardCrypto)])
mkProtocolInfoCardano GenesisConfig
genesisConfig

newtype LedgerState = LedgerState
  { LedgerState -> CardanoLedgerState StandardCrypto
clsState :: Consensus.CardanoLedgerState Consensus.StandardCrypto
  }
  deriving Int -> LedgerState -> ShowS
[LedgerState] -> ShowS
LedgerState -> String
(Int -> LedgerState -> ShowS)
-> (LedgerState -> String)
-> ([LedgerState] -> ShowS)
-> Show LedgerState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LedgerState -> ShowS
showsPrec :: Int -> LedgerState -> ShowS
$cshow :: LedgerState -> String
show :: LedgerState -> String
$cshowList :: [LedgerState] -> ShowS
showList :: [LedgerState] -> ShowS
Show

-- | Retrieve new epoch state from the ledger state, or an error on failure
getAnyNewEpochState
  :: ShelleyBasedEra era
  -> LedgerState
  -> Either LedgerStateError AnyNewEpochState
getAnyNewEpochState :: forall era.
ShelleyBasedEra era
-> LedgerState -> Either LedgerStateError AnyNewEpochState
getAnyNewEpochState ShelleyBasedEra era
sbe (LedgerState CardanoLedgerState StandardCrypto
ls) =
  ShelleyBasedEra era
-> NewEpochState (ShelleyLedgerEra era) -> AnyNewEpochState
forall era.
ShelleyBasedEra era
-> NewEpochState (ShelleyLedgerEra era) -> AnyNewEpochState
AnyNewEpochState ShelleyBasedEra era
sbe (NewEpochState (ShelleyLedgerEra era) -> AnyNewEpochState)
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
-> Either LedgerStateError AnyNewEpochState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShelleyBasedEra era
-> CardanoLedgerState StandardCrypto
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall era.
ShelleyBasedEra era
-> CardanoLedgerState StandardCrypto
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
getNewEpochState ShelleyBasedEra era
sbe CardanoLedgerState StandardCrypto
ls

getNewEpochState
  :: ShelleyBasedEra era
  -> Consensus.CardanoLedgerState Consensus.StandardCrypto
  -> Either LedgerStateError (ShelleyAPI.NewEpochState (ShelleyLedgerEra era))
getNewEpochState :: forall era.
ShelleyBasedEra era
-> CardanoLedgerState StandardCrypto
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
getNewEpochState ShelleyBasedEra era
era CardanoLedgerState StandardCrypto
x = do
  let err :: LedgerStateError
err = AnyShelleyBasedEra
-> CardanoLedgerState StandardCrypto -> LedgerStateError
UnexpectedLedgerState (ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era => AnyShelleyBasedEra)
-> AnyShelleyBasedEra
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
era ((ShelleyBasedEraConstraints era => AnyShelleyBasedEra)
 -> AnyShelleyBasedEra)
-> (ShelleyBasedEraConstraints era => AnyShelleyBasedEra)
-> AnyShelleyBasedEra
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era -> AnyShelleyBasedEra
forall era.
Typeable era =>
ShelleyBasedEra era -> AnyShelleyBasedEra
AnyShelleyBasedEra ShelleyBasedEra era
era) CardanoLedgerState StandardCrypto
x
  case ShelleyBasedEra era
era of
    ShelleyBasedEra era
ShelleyBasedEraShelley ->
      case CardanoLedgerState StandardCrypto
x of
        Consensus.LedgerStateShelley LedgerState
  (ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto))
current ->
          NewEpochState (ShelleyLedgerEra era)
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall a. a -> Either LedgerStateError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewEpochState (ShelleyLedgerEra era)
 -> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era)))
-> NewEpochState (ShelleyLedgerEra era)
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall a b. (a -> b) -> a -> b
$ LedgerState
  (ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto))
-> NewEpochState (ShelleyEra StandardCrypto)
forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
Shelley.shelleyLedgerState LedgerState
  (ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto))
current
        CardanoLedgerState StandardCrypto
_ -> LedgerStateError
-> Either
     LedgerStateError (NewEpochState (ShelleyEra StandardCrypto))
forall a b. a -> Either a b
Left LedgerStateError
err
    ShelleyBasedEra era
ShelleyBasedEraAllegra ->
      case CardanoLedgerState StandardCrypto
x of
        Consensus.LedgerStateAllegra LedgerState
  (ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto))
current ->
          NewEpochState (ShelleyLedgerEra era)
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall a. a -> Either LedgerStateError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewEpochState (ShelleyLedgerEra era)
 -> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era)))
-> NewEpochState (ShelleyLedgerEra era)
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall a b. (a -> b) -> a -> b
$ LedgerState
  (ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto))
-> NewEpochState (AllegraEra StandardCrypto)
forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
Shelley.shelleyLedgerState LedgerState
  (ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto))
current
        CardanoLedgerState StandardCrypto
_ -> LedgerStateError
-> Either
     LedgerStateError (NewEpochState (AllegraEra StandardCrypto))
forall a b. a -> Either a b
Left LedgerStateError
err
    ShelleyBasedEra era
ShelleyBasedEraMary ->
      case CardanoLedgerState StandardCrypto
x of
        Consensus.LedgerStateMary LedgerState
  (ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto))
current ->
          NewEpochState (ShelleyLedgerEra era)
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall a. a -> Either LedgerStateError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewEpochState (ShelleyLedgerEra era)
 -> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era)))
-> NewEpochState (ShelleyLedgerEra era)
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall a b. (a -> b) -> a -> b
$ LedgerState
  (ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto))
-> NewEpochState (MaryEra StandardCrypto)
forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
Shelley.shelleyLedgerState LedgerState
  (ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto))
current
        CardanoLedgerState StandardCrypto
_ -> LedgerStateError
-> Either LedgerStateError (NewEpochState (MaryEra StandardCrypto))
forall a b. a -> Either a b
Left LedgerStateError
err
    ShelleyBasedEra era
ShelleyBasedEraAlonzo ->
      case CardanoLedgerState StandardCrypto
x of
        Consensus.LedgerStateAlonzo LedgerState
  (ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto))
current ->
          NewEpochState (ShelleyLedgerEra era)
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall a. a -> Either LedgerStateError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewEpochState (ShelleyLedgerEra era)
 -> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era)))
-> NewEpochState (ShelleyLedgerEra era)
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall a b. (a -> b) -> a -> b
$ LedgerState
  (ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto))
-> NewEpochState (AlonzoEra StandardCrypto)
forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
Shelley.shelleyLedgerState LedgerState
  (ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto))
current
        CardanoLedgerState StandardCrypto
_ -> LedgerStateError
-> Either
     LedgerStateError (NewEpochState (AlonzoEra StandardCrypto))
forall a b. a -> Either a b
Left LedgerStateError
err
    ShelleyBasedEra era
ShelleyBasedEraBabbage ->
      case CardanoLedgerState StandardCrypto
x of
        Consensus.LedgerStateBabbage LedgerState
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
current ->
          NewEpochState (ShelleyLedgerEra era)
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall a. a -> Either LedgerStateError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewEpochState (ShelleyLedgerEra era)
 -> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era)))
-> NewEpochState (ShelleyLedgerEra era)
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall a b. (a -> b) -> a -> b
$ LedgerState
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
-> NewEpochState (BabbageEra StandardCrypto)
forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
Shelley.shelleyLedgerState LedgerState
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
current
        CardanoLedgerState StandardCrypto
_ -> LedgerStateError
-> Either
     LedgerStateError (NewEpochState (BabbageEra StandardCrypto))
forall a b. a -> Either a b
Left LedgerStateError
err
    ShelleyBasedEra era
ShelleyBasedEraConway ->
      case CardanoLedgerState StandardCrypto
x of
        Consensus.LedgerStateConway LedgerState
  (ShelleyBlock
     (Praos StandardCrypto) (LatestKnownEra StandardCrypto))
current ->
          NewEpochState (ShelleyLedgerEra era)
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall a. a -> Either LedgerStateError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewEpochState (ShelleyLedgerEra era)
 -> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era)))
-> NewEpochState (ShelleyLedgerEra era)
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall a b. (a -> b) -> a -> b
$ LedgerState
  (ShelleyBlock
     (Praos StandardCrypto) (LatestKnownEra StandardCrypto))
-> NewEpochState (LatestKnownEra StandardCrypto)
forall proto era.
LedgerState (ShelleyBlock proto era) -> NewEpochState era
Shelley.shelleyLedgerState LedgerState
  (ShelleyBlock
     (Praos StandardCrypto) (LatestKnownEra StandardCrypto))
current
        CardanoLedgerState StandardCrypto
_ -> LedgerStateError
-> Either
     LedgerStateError (NewEpochState (LatestKnownEra StandardCrypto))
forall a b. a -> Either a b
Left LedgerStateError
err

encodeLedgerState
  :: Consensus.CardanoCodecConfig Consensus.StandardCrypto
  -> LedgerState
  -> CBOR.Encoding
encodeLedgerState :: CardanoCodecConfig StandardCrypto -> LedgerState -> Encoding
encodeLedgerState CardanoCodecConfig StandardCrypto
ccfg (LedgerState CardanoLedgerState StandardCrypto
st) =
  forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk @(Consensus.CardanoBlock Consensus.StandardCrypto) CardanoCodecConfig StandardCrypto
ccfg CardanoLedgerState StandardCrypto
st

decodeLedgerState
  :: Consensus.CardanoCodecConfig Consensus.StandardCrypto
  -> forall s
   . CBOR.Decoder s LedgerState
decodeLedgerState :: CardanoCodecConfig StandardCrypto
-> forall s. Decoder s LedgerState
decodeLedgerState CardanoCodecConfig StandardCrypto
ccfg =
  CardanoLedgerState StandardCrypto -> LedgerState
LedgerState (CardanoLedgerState StandardCrypto -> LedgerState)
-> Decoder s (CardanoLedgerState StandardCrypto)
-> Decoder s LedgerState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall blk a.
DecodeDisk blk a =>
CodecConfig blk -> forall s. Decoder s a
decodeDisk @(Consensus.CardanoBlock Consensus.StandardCrypto) CardanoCodecConfig StandardCrypto
ccfg

type LedgerStateEvents = (LedgerState, [LedgerEvent])

toLedgerStateEvents
  :: Ledger.LedgerResult
      (Consensus.CardanoLedgerState Consensus.StandardCrypto)
      (Consensus.CardanoLedgerState Consensus.StandardCrypto)
  -> LedgerStateEvents
toLedgerStateEvents :: LedgerResult
  (CardanoLedgerState StandardCrypto)
  (CardanoLedgerState StandardCrypto)
-> LedgerStateEvents
toLedgerStateEvents LedgerResult
  (CardanoLedgerState StandardCrypto)
  (CardanoLedgerState StandardCrypto)
lr = (LedgerState
ledgerState, [LedgerEvent]
ledgerEvents)
 where
  ledgerState :: LedgerState
ledgerState = CardanoLedgerState StandardCrypto -> LedgerState
LedgerState (LedgerResult
  (CardanoLedgerState StandardCrypto)
  (CardanoLedgerState StandardCrypto)
-> CardanoLedgerState StandardCrypto
forall l a. LedgerResult l a -> a
Ledger.lrResult LedgerResult
  (CardanoLedgerState StandardCrypto)
  (CardanoLedgerState StandardCrypto)
lr)
  ledgerEvents :: [LedgerEvent]
ledgerEvents =
    (OneEraLedgerEvent (ByronBlock : CardanoShelleyEras StandardCrypto)
 -> Maybe LedgerEvent)
-> [OneEraLedgerEvent
      (ByronBlock : CardanoShelleyEras StandardCrypto)]
-> [LedgerEvent]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
      ( WrapLedgerEvent (CardanoBlock StandardCrypto) -> Maybe LedgerEvent
forall blk.
ConvertLedgerEvent blk =>
WrapLedgerEvent blk -> Maybe LedgerEvent
toLedgerEvent
          (WrapLedgerEvent (CardanoBlock StandardCrypto)
 -> Maybe LedgerEvent)
-> (OneEraLedgerEvent
      (ByronBlock : CardanoShelleyEras StandardCrypto)
    -> WrapLedgerEvent (CardanoBlock StandardCrypto))
-> OneEraLedgerEvent
     (ByronBlock : CardanoShelleyEras StandardCrypto)
-> Maybe LedgerEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall blk. AuxLedgerEvent (LedgerState blk) -> WrapLedgerEvent blk
WrapLedgerEvent @(Consensus.CardanoBlock Consensus.StandardCrypto)
      )
      ([OneEraLedgerEvent
    (ByronBlock : CardanoShelleyEras StandardCrypto)]
 -> [LedgerEvent])
-> [OneEraLedgerEvent
      (ByronBlock : CardanoShelleyEras StandardCrypto)]
-> [LedgerEvent]
forall a b. (a -> b) -> a -> b
$ LedgerResult
  (CardanoLedgerState StandardCrypto)
  (CardanoLedgerState StandardCrypto)
-> [AuxLedgerEvent (CardanoLedgerState StandardCrypto)]
forall l a. LedgerResult l a -> [AuxLedgerEvent l]
Ledger.lrEvents LedgerResult
  (CardanoLedgerState StandardCrypto)
  (CardanoLedgerState StandardCrypto)
lr

-- Usually only one constructor, but may have two when we are preparing for a HFC event.
data GenesisConfig
  = GenesisCardano
      !NodeConfig
      !Cardano.Chain.Genesis.Config
      !GenesisHashShelley
      !(Ledger.TransitionConfig (Ledger.LatestKnownEra Consensus.StandardCrypto))

newtype LedgerStateDir = LedgerStateDir
  { LedgerStateDir -> String
unLedgerStateDir :: FilePath
  }
  deriving Int -> LedgerStateDir -> ShowS
[LedgerStateDir] -> ShowS
LedgerStateDir -> String
(Int -> LedgerStateDir -> ShowS)
-> (LedgerStateDir -> String)
-> ([LedgerStateDir] -> ShowS)
-> Show LedgerStateDir
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LedgerStateDir -> ShowS
showsPrec :: Int -> LedgerStateDir -> ShowS
$cshow :: LedgerStateDir -> String
show :: LedgerStateDir -> String
$cshowList :: [LedgerStateDir] -> ShowS
showList :: [LedgerStateDir] -> ShowS
Show

newtype NetworkName = NetworkName
  { NetworkName -> Text
unNetworkName :: Text
  }
  deriving Int -> NetworkName -> ShowS
[NetworkName] -> ShowS
NetworkName -> String
(Int -> NetworkName -> ShowS)
-> (NetworkName -> String)
-> ([NetworkName] -> ShowS)
-> Show NetworkName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NetworkName -> ShowS
showsPrec :: Int -> NetworkName -> ShowS
$cshow :: NetworkName -> String
show :: NetworkName -> String
$cshowList :: [NetworkName] -> ShowS
showList :: [NetworkName] -> ShowS
Show

type NodeConfigFile = File NodeConfig

mkProtocolInfoCardano
  :: GenesisConfig
  -> ( Consensus.ProtocolInfo
        (Consensus.CardanoBlock Consensus.StandardCrypto)
     , IO [BlockForging IO (Consensus.CardanoBlock Consensus.StandardCrypto)]
     )
mkProtocolInfoCardano :: GenesisConfig
-> (ProtocolInfo (CardanoBlock StandardCrypto),
    IO [BlockForging IO (CardanoBlock StandardCrypto)])
mkProtocolInfoCardano (GenesisCardano NodeConfig
dnc Config
byronGenesis GenesisHashShelley
shelleyGenesisHash TransitionConfig (LatestKnownEra StandardCrypto)
transCfg) =
  CardanoProtocolParams StandardCrypto
-> (ProtocolInfo (CardanoBlock StandardCrypto),
    IO [BlockForging IO (CardanoBlock StandardCrypto)])
forall c (m :: * -> *).
(IOLike m, CardanoHardForkConstraints c) =>
CardanoProtocolParams c
-> (ProtocolInfo (CardanoBlock c),
    m [BlockForging m (CardanoBlock c)])
Consensus.protocolInfoCardano
    Consensus.CardanoProtocolParams
      { byronProtocolParams :: ProtocolParamsByron
Consensus.byronProtocolParams =
          Consensus.ProtocolParamsByron
            { byronGenesis :: Config
Consensus.byronGenesis = Config
byronGenesis
            , byronPbftSignatureThreshold :: Maybe PBftSignatureThreshold
Consensus.byronPbftSignatureThreshold =
                Double -> PBftSignatureThreshold
Consensus.PBftSignatureThreshold (Double -> PBftSignatureThreshold)
-> Maybe Double -> Maybe PBftSignatureThreshold
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeConfig -> Maybe Double
ncPBftSignatureThreshold NodeConfig
dnc
            , byronProtocolVersion :: ProtocolVersion
Consensus.byronProtocolVersion = NodeConfig -> ProtocolVersion
ncByronProtocolVersion NodeConfig
dnc
            , byronSoftwareVersion :: SoftwareVersion
Consensus.byronSoftwareVersion = SoftwareVersion
Byron.softwareVersion
            , byronLeaderCredentials :: Maybe ByronLeaderCredentials
Consensus.byronLeaderCredentials = Maybe ByronLeaderCredentials
forall a. Maybe a
Nothing
            }
      , shelleyBasedProtocolParams :: ProtocolParamsShelleyBased StandardCrypto
Consensus.shelleyBasedProtocolParams =
          Consensus.ProtocolParamsShelleyBased
            { shelleyBasedInitialNonce :: Nonce
Consensus.shelleyBasedInitialNonce = GenesisHashShelley -> Nonce
shelleyPraosNonce GenesisHashShelley
shelleyGenesisHash
            , shelleyBasedLeaderCredentials :: [ShelleyLeaderCredentials StandardCrypto]
Consensus.shelleyBasedLeaderCredentials = []
            }
      , cardanoHardForkTriggers :: CardanoHardForkTriggers
Consensus.cardanoHardForkTriggers = NodeConfig -> CardanoHardForkTriggers
ncHardForkTriggers NodeConfig
dnc
      , cardanoLedgerTransitionConfig :: TransitionConfig (LatestKnownEra StandardCrypto)
Consensus.cardanoLedgerTransitionConfig = TransitionConfig (LatestKnownEra StandardCrypto)
transCfg
      , -- NOTE: this can become a parameter once https://github.com/IntersectMBO/cardano-node/issues/5730 is implemented.
        cardanoCheckpoints :: CheckpointsMap (CardanoBlock StandardCrypto)
Consensus.cardanoCheckpoints = CheckpointsMap (CardanoBlock StandardCrypto)
forall blk. CheckpointsMap blk
Consensus.emptyCheckpointsMap
      , cardanoProtocolVersion :: ProtVer
Consensus.cardanoProtocolVersion = Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @10) Natural
0
      }

-- | Compute the Nonce from the hash of the Genesis file.
shelleyPraosNonce :: GenesisHashShelley -> Ledger.Nonce
shelleyPraosNonce :: GenesisHashShelley -> Nonce
shelleyPraosNonce GenesisHashShelley
genesisHash =
  Hash Blake2b_256 Nonce -> Nonce
Ledger.Nonce (Hash Blake2b_256 ByteString -> Hash Blake2b_256 Nonce
forall h a b. Hash h a -> Hash h b
Cardano.Crypto.Hash.Class.castHash (Hash Blake2b_256 ByteString -> Hash Blake2b_256 Nonce)
-> Hash Blake2b_256 ByteString -> Hash Blake2b_256 Nonce
forall a b. (a -> b) -> a -> b
$ GenesisHashShelley -> Hash Blake2b_256 ByteString
unGenesisHashShelley GenesisHashShelley
genesisHash)

readCardanoGenesisConfig
  :: MonadIOTransError GenesisConfigError t m
  => Maybe (CardanoEra era)
  -- ^ Provide era witness to read Alonzo Genesis in an era-sensitive manner (see
  -- 'Cardano.Api.Genesis.decodeAlonzGenesis' for more details)
  -> NodeConfig
  -> t m GenesisConfig
readCardanoGenesisConfig :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) era.
MonadIOTransError GenesisConfigError t m =>
Maybe (CardanoEra era) -> NodeConfig -> t m GenesisConfig
readCardanoGenesisConfig Maybe (CardanoEra era)
mEra NodeConfig
enc = do
  Config
byronGenesis <- NodeConfig -> t m Config
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError GenesisConfigError t m =>
NodeConfig -> t m Config
readByronGenesisConfig NodeConfig
enc
  ShelleyConfig ShelleyGenesis StandardCrypto
shelleyGenesis GenesisHashShelley
shelleyGenesisHash <- NodeConfig -> t m ShelleyGenesisConfig
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError GenesisConfigError t m =>
NodeConfig -> t m ShelleyGenesisConfig
readShelleyGenesisConfig NodeConfig
enc
  AlonzoGenesis
alonzoGenesis <- Maybe (CardanoEra era) -> NodeConfig -> t m AlonzoGenesis
forall (t :: (* -> *) -> * -> *) (m :: * -> *) era.
MonadIOTransError GenesisConfigError t m =>
Maybe (CardanoEra era) -> NodeConfig -> t m AlonzoGenesis
readAlonzoGenesisConfig Maybe (CardanoEra era)
mEra NodeConfig
enc
  ConwayGenesisConfig
conwayGenesis <- NodeConfig -> t m ConwayGenesisConfig
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError GenesisConfigError t m =>
NodeConfig -> t m ConwayGenesisConfig
readConwayGenesisConfig NodeConfig
enc
  let transCfg :: TransitionConfig (LatestKnownEra StandardCrypto)
transCfg = ShelleyGenesis StandardCrypto
-> AlonzoGenesis
-> ConwayGenesisConfig
-> TransitionConfig (LatestKnownEra StandardCrypto)
forall c.
Crypto c =>
ShelleyGenesis c
-> AlonzoGenesis
-> ConwayGenesis c
-> TransitionConfig (LatestKnownEra c)
Ledger.mkLatestTransitionConfig ShelleyGenesis StandardCrypto
shelleyGenesis AlonzoGenesis
alonzoGenesis ConwayGenesisConfig
conwayGenesis
  GenesisConfig -> t m GenesisConfig
forall a. a -> t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenesisConfig -> t m GenesisConfig)
-> GenesisConfig -> t m GenesisConfig
forall a b. (a -> b) -> a -> b
$ NodeConfig
-> Config
-> GenesisHashShelley
-> TransitionConfig (LatestKnownEra StandardCrypto)
-> GenesisConfig
GenesisCardano NodeConfig
enc Config
byronGenesis GenesisHashShelley
shelleyGenesisHash TransitionConfig (LatestKnownEra StandardCrypto)
transCfg

data GenesisConfigError
  = NEError !Text
  | NEByronConfig !FilePath !Cardano.Chain.Genesis.ConfigurationError
  | NEShelleyConfig !FilePath !Text
  | NEAlonzoConfig !FilePath !Text
  | NEConwayConfig !FilePath !Text
  | NECardanoConfig !Text
  deriving Int -> GenesisConfigError -> ShowS
[GenesisConfigError] -> ShowS
GenesisConfigError -> String
(Int -> GenesisConfigError -> ShowS)
-> (GenesisConfigError -> String)
-> ([GenesisConfigError] -> ShowS)
-> Show GenesisConfigError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GenesisConfigError -> ShowS
showsPrec :: Int -> GenesisConfigError -> ShowS
$cshow :: GenesisConfigError -> String
show :: GenesisConfigError -> String
$cshowList :: [GenesisConfigError] -> ShowS
showList :: [GenesisConfigError] -> ShowS
Show

instance Exception GenesisConfigError

instance Error GenesisConfigError where
  prettyError :: forall ann. GenesisConfigError -> Doc ann
prettyError = \case
    NEError Text
t -> Doc ann
"Error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
t
    NEByronConfig String
fp ConfigurationError
ce ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
        [ Doc ann
"Failed reading Byron genesis file "
        , String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
fp
        , Doc ann
": "
        , ConfigurationError -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow ConfigurationError
ce
        ]
    NEShelleyConfig String
fp Text
txt ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
        [ Doc ann
"Failed reading Shelley genesis file "
        , String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
fp
        , Doc ann
": "
        , Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
txt
        ]
    NEAlonzoConfig String
fp Text
txt ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
        [ Doc ann
"Failed reading Alonzo genesis file "
        , String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
fp
        , Doc ann
": "
        , Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
txt
        ]
    NEConwayConfig String
fp Text
txt ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
        [ Doc ann
"Failed reading Conway genesis file "
        , String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
fp
        , Doc ann
": "
        , Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
txt
        ]
    NECardanoConfig Text
err ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
        [ Doc ann
"With Cardano protocol, Byron/Shelley config mismatch:\n"
        , Doc ann
"   "
        , Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
err
        ]

readByronGenesisConfig
  :: MonadIOTransError GenesisConfigError t m
  => NodeConfig
  -> t m Cardano.Chain.Genesis.Config
readByronGenesisConfig :: forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError GenesisConfigError t m =>
NodeConfig -> t m Config
readByronGenesisConfig NodeConfig
enc = do
  let file :: String
file = File Config 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
unFile (File Config 'In -> String) -> File Config 'In -> String
forall a b. (a -> b) -> a -> b
$ NodeConfig -> File Config 'In
ncByronGenesisFile NodeConfig
enc
  AbstractHash Blake2b_256 Raw
genHash <-
    Either GenesisConfigError (AbstractHash Blake2b_256 Raw)
-> t m (AbstractHash Blake2b_256 Raw)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
      (Either GenesisConfigError (AbstractHash Blake2b_256 Raw)
 -> t m (AbstractHash Blake2b_256 Raw))
-> (Either Text (AbstractHash Blake2b_256 Raw)
    -> Either GenesisConfigError (AbstractHash Blake2b_256 Raw))
-> Either Text (AbstractHash Blake2b_256 Raw)
-> t m (AbstractHash Blake2b_256 Raw)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> GenesisConfigError)
-> Either Text (AbstractHash Blake2b_256 Raw)
-> Either GenesisConfigError (AbstractHash Blake2b_256 Raw)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> GenesisConfigError
NEError
      (Either Text (AbstractHash Blake2b_256 Raw)
 -> t m (AbstractHash Blake2b_256 Raw))
-> Either Text (AbstractHash Blake2b_256 Raw)
-> t m (AbstractHash Blake2b_256 Raw)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (AbstractHash Blake2b_256 Raw)
forall algo a.
HashAlgorithm algo =>
Text -> Either Text (AbstractHash algo a)
Cardano.Crypto.Hashing.decodeAbstractHash (GenesisHashByron -> Text
unGenesisHashByron (GenesisHashByron -> Text) -> GenesisHashByron -> Text
forall a b. (a -> b) -> a -> b
$ NodeConfig -> GenesisHashByron
ncByronGenesisHash NodeConfig
enc)
  (ConfigurationError -> GenesisConfigError)
-> ExceptT ConfigurationError m Config -> t m Config
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError (String -> ConfigurationError -> GenesisConfigError
NEByronConfig String
file) (ExceptT ConfigurationError m Config -> t m Config)
-> ExceptT ConfigurationError m Config -> t m Config
forall a b. (a -> b) -> a -> b
$
    RequiresNetworkMagic
-> String
-> AbstractHash Blake2b_256 Raw
-> ExceptT ConfigurationError m Config
forall (m :: * -> *).
(MonadError ConfigurationError m, MonadIO m) =>
RequiresNetworkMagic
-> String -> AbstractHash Blake2b_256 Raw -> m Config
Cardano.Chain.Genesis.mkConfigFromFile (NodeConfig -> RequiresNetworkMagic
ncRequiresNetworkMagic NodeConfig
enc) String
file AbstractHash Blake2b_256 Raw
genHash

readShelleyGenesisConfig
  :: MonadIOTransError GenesisConfigError t m
  => NodeConfig
  -> t m ShelleyConfig
readShelleyGenesisConfig :: forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError GenesisConfigError t m =>
NodeConfig -> t m ShelleyGenesisConfig
readShelleyGenesisConfig NodeConfig
enc = do
  let file :: File ShelleyGenesisConfig 'In
file = NodeConfig -> File ShelleyGenesisConfig 'In
ncShelleyGenesisFile NodeConfig
enc
  (ShelleyGenesisError -> GenesisConfigError)
-> ExceptT ShelleyGenesisError m ShelleyGenesisConfig
-> t m ShelleyGenesisConfig
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError (String -> Text -> GenesisConfigError
NEShelleyConfig (File ShelleyGenesisConfig 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
unFile File ShelleyGenesisConfig 'In
file) (Text -> GenesisConfigError)
-> (ShelleyGenesisError -> Text)
-> ShelleyGenesisError
-> GenesisConfigError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesisError -> Text
renderShelleyGenesisError) (ExceptT ShelleyGenesisError m ShelleyGenesisConfig
 -> t m ShelleyGenesisConfig)
-> ExceptT ShelleyGenesisError m ShelleyGenesisConfig
-> t m ShelleyGenesisConfig
forall a b. (a -> b) -> a -> b
$
    File ShelleyGenesisConfig 'In
-> GenesisHashShelley
-> ExceptT ShelleyGenesisError m ShelleyGenesisConfig
forall (m :: * -> *) (t :: (* -> *) -> * -> *).
MonadIOTransError ShelleyGenesisError t m =>
File ShelleyGenesisConfig 'In
-> GenesisHashShelley -> t m ShelleyGenesisConfig
readShelleyGenesis File ShelleyGenesisConfig 'In
file (NodeConfig -> GenesisHashShelley
ncShelleyGenesisHash NodeConfig
enc)

readAlonzoGenesisConfig
  :: MonadIOTransError GenesisConfigError t m
  => Maybe (CardanoEra era)
  -- ^ Provide era witness to read Alonzo Genesis in an era-sensitive manner (see
  -- 'Cardano.Api.Genesis.decodeAlonzGenesis' for more details)
  -> NodeConfig
  -> t m AlonzoGenesis
readAlonzoGenesisConfig :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) era.
MonadIOTransError GenesisConfigError t m =>
Maybe (CardanoEra era) -> NodeConfig -> t m AlonzoGenesis
readAlonzoGenesisConfig Maybe (CardanoEra era)
mEra NodeConfig
enc = do
  let file :: File AlonzoGenesis 'In
file = NodeConfig -> File AlonzoGenesis 'In
ncAlonzoGenesisFile NodeConfig
enc
  (AlonzoGenesisError -> GenesisConfigError)
-> ExceptT AlonzoGenesisError m AlonzoGenesis -> t m AlonzoGenesis
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError (String -> Text -> GenesisConfigError
NEAlonzoConfig (File AlonzoGenesis 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
unFile File AlonzoGenesis 'In
file) (Text -> GenesisConfigError)
-> (AlonzoGenesisError -> Text)
-> AlonzoGenesisError
-> GenesisConfigError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoGenesisError -> Text
renderAlonzoGenesisError) (ExceptT AlonzoGenesisError m AlonzoGenesis -> t m AlonzoGenesis)
-> ExceptT AlonzoGenesisError m AlonzoGenesis -> t m AlonzoGenesis
forall a b. (a -> b) -> a -> b
$
    Maybe (CardanoEra era)
-> File AlonzoGenesis 'In
-> GenesisHashAlonzo
-> ExceptT AlonzoGenesisError m AlonzoGenesis
forall (m :: * -> *) (t :: (* -> *) -> * -> *) era.
MonadIOTransError AlonzoGenesisError t m =>
Maybe (CardanoEra era)
-> File AlonzoGenesis 'In -> GenesisHashAlonzo -> t m AlonzoGenesis
readAlonzoGenesis Maybe (CardanoEra era)
mEra File AlonzoGenesis 'In
file (NodeConfig -> GenesisHashAlonzo
ncAlonzoGenesisHash NodeConfig
enc)

-- | If the conway genesis file does not exist we simply put in a default.
readConwayGenesisConfig
  :: MonadIOTransError GenesisConfigError t m
  => NodeConfig
  -> t m (ConwayGenesis Consensus.StandardCrypto)
readConwayGenesisConfig :: forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError GenesisConfigError t m =>
NodeConfig -> t m ConwayGenesisConfig
readConwayGenesisConfig NodeConfig
enc = do
  let mFile :: Maybe (File ConwayGenesisConfig 'In)
mFile = NodeConfig -> Maybe (File ConwayGenesisConfig 'In)
ncConwayGenesisFile NodeConfig
enc
  case Maybe (File ConwayGenesisConfig 'In)
mFile of
    Maybe (File ConwayGenesisConfig 'In)
Nothing -> ConwayGenesisConfig -> t m ConwayGenesisConfig
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return ConwayGenesisConfig
conwayGenesisDefaults
    Just File ConwayGenesisConfig 'In
fp ->
      (ConwayGenesisError -> GenesisConfigError)
-> ExceptT ConwayGenesisError m ConwayGenesisConfig
-> t m ConwayGenesisConfig
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError (String -> Text -> GenesisConfigError
NEConwayConfig (File ConwayGenesisConfig 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
unFile File ConwayGenesisConfig 'In
fp) (Text -> GenesisConfigError)
-> (ConwayGenesisError -> Text)
-> ConwayGenesisError
-> GenesisConfigError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayGenesisError -> Text
renderConwayGenesisError) (ExceptT ConwayGenesisError m ConwayGenesisConfig
 -> t m ConwayGenesisConfig)
-> ExceptT ConwayGenesisError m ConwayGenesisConfig
-> t m ConwayGenesisConfig
forall a b. (a -> b) -> a -> b
$
        Maybe (File ConwayGenesisConfig 'In)
-> Maybe GenesisHashConway
-> ExceptT ConwayGenesisError m ConwayGenesisConfig
forall (m :: * -> *) (t :: (* -> *) -> * -> *).
MonadIOTransError ConwayGenesisError t m =>
Maybe (File ConwayGenesisConfig 'In)
-> Maybe GenesisHashConway -> t m ConwayGenesisConfig
readConwayGenesis (NodeConfig -> Maybe (File ConwayGenesisConfig 'In)
ncConwayGenesisFile NodeConfig
enc) (NodeConfig -> Maybe GenesisHashConway
ncConwayGenesisHash NodeConfig
enc)

readShelleyGenesis
  :: forall m t
   . MonadIOTransError ShelleyGenesisError t m
  => ShelleyGenesisFile 'In
  -> GenesisHashShelley
  -> t m ShelleyConfig
readShelleyGenesis :: forall (m :: * -> *) (t :: (* -> *) -> * -> *).
MonadIOTransError ShelleyGenesisError t m =>
File ShelleyGenesisConfig 'In
-> GenesisHashShelley -> t m ShelleyGenesisConfig
readShelleyGenesis (File String
file) GenesisHashShelley
expectedGenesisHash = do
  ByteString
content <-
    (ShelleyGenesisError -> ShelleyGenesisError)
-> ExceptT ShelleyGenesisError m ByteString -> t m ByteString
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError ShelleyGenesisError -> ShelleyGenesisError
forall a. a -> a
id (ExceptT ShelleyGenesisError m ByteString -> t m ByteString)
-> ExceptT ShelleyGenesisError m ByteString -> t m ByteString
forall a b. (a -> b) -> a -> b
$ (IOException -> ShelleyGenesisError)
-> IO ByteString -> ExceptT ShelleyGenesisError m ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (String -> Text -> ShelleyGenesisError
ShelleyGenesisReadError String
file (Text -> ShelleyGenesisError)
-> (IOException -> Text) -> IOException -> ShelleyGenesisError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> Text
forall a. Show a => a -> Text
textShow) (IO ByteString -> ExceptT ShelleyGenesisError m ByteString)
-> IO ByteString -> ExceptT ShelleyGenesisError m ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
file
  let genesisHash :: GenesisHashShelley
genesisHash = Hash Blake2b_256 ByteString -> GenesisHashShelley
GenesisHashShelley ((ByteString -> ByteString)
-> ByteString -> Hash Blake2b_256 ByteString
forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Cardano.Crypto.Hash.Class.hashWith ByteString -> ByteString
forall a. a -> a
id ByteString
content)
  GenesisHashShelley -> t m ()
checkExpectedGenesisHash GenesisHashShelley
genesisHash
  ShelleyGenesis StandardCrypto
genesis <-
    Either ShelleyGenesisError (ShelleyGenesis StandardCrypto)
-> t m (ShelleyGenesis StandardCrypto)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
      (Either ShelleyGenesisError (ShelleyGenesis StandardCrypto)
 -> t m (ShelleyGenesis StandardCrypto))
-> (Either String (ShelleyGenesis StandardCrypto)
    -> Either ShelleyGenesisError (ShelleyGenesis StandardCrypto))
-> Either String (ShelleyGenesis StandardCrypto)
-> t m (ShelleyGenesis StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShelleyGenesisError)
-> Either String (ShelleyGenesis StandardCrypto)
-> Either ShelleyGenesisError (ShelleyGenesis StandardCrypto)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text -> ShelleyGenesisError
ShelleyGenesisDecodeError String
file (Text -> ShelleyGenesisError)
-> (String -> Text) -> String -> ShelleyGenesisError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack)
      (Either String (ShelleyGenesis StandardCrypto)
 -> t m (ShelleyGenesis StandardCrypto))
-> Either String (ShelleyGenesis StandardCrypto)
-> t m (ShelleyGenesis StandardCrypto)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String (ShelleyGenesis StandardCrypto)
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict' ByteString
content
  ShelleyGenesisConfig -> t m ShelleyGenesisConfig
forall a. a -> t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShelleyGenesisConfig -> t m ShelleyGenesisConfig)
-> ShelleyGenesisConfig -> t m ShelleyGenesisConfig
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis StandardCrypto
-> GenesisHashShelley -> ShelleyGenesisConfig
ShelleyConfig ShelleyGenesis StandardCrypto
genesis GenesisHashShelley
genesisHash
 where
  checkExpectedGenesisHash :: GenesisHashShelley -> t m ()
  checkExpectedGenesisHash :: GenesisHashShelley -> t m ()
checkExpectedGenesisHash GenesisHashShelley
actual =
    Bool -> t m () -> t m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GenesisHashShelley
actual GenesisHashShelley -> GenesisHashShelley -> Bool
forall a. Eq a => a -> a -> Bool
/= GenesisHashShelley
expectedGenesisHash) (t m () -> t m ()) -> t m () -> t m ()
forall a b. (a -> b) -> a -> b
$
      ShelleyGenesisError -> t m ()
forall a. ShelleyGenesisError -> t m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GenesisHashShelley -> GenesisHashShelley -> ShelleyGenesisError
ShelleyGenesisHashMismatch GenesisHashShelley
actual GenesisHashShelley
expectedGenesisHash)

data ShelleyGenesisError
  = ShelleyGenesisReadError !FilePath !Text
  | ShelleyGenesisHashMismatch !GenesisHashShelley !GenesisHashShelley -- actual, expected
  | ShelleyGenesisDecodeError !FilePath !Text
  deriving Int -> ShelleyGenesisError -> ShowS
[ShelleyGenesisError] -> ShowS
ShelleyGenesisError -> String
(Int -> ShelleyGenesisError -> ShowS)
-> (ShelleyGenesisError -> String)
-> ([ShelleyGenesisError] -> ShowS)
-> Show ShelleyGenesisError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShelleyGenesisError -> ShowS
showsPrec :: Int -> ShelleyGenesisError -> ShowS
$cshow :: ShelleyGenesisError -> String
show :: ShelleyGenesisError -> String
$cshowList :: [ShelleyGenesisError] -> ShowS
showList :: [ShelleyGenesisError] -> ShowS
Show

instance Exception ShelleyGenesisError

renderShelleyGenesisError :: ShelleyGenesisError -> Text
renderShelleyGenesisError :: ShelleyGenesisError -> Text
renderShelleyGenesisError ShelleyGenesisError
sge =
  case ShelleyGenesisError
sge of
    ShelleyGenesisReadError String
fp Text
err ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"There was an error reading the genesis file: "
        , String -> Text
Text.pack String
fp
        , Text
" Error: "
        , Text
err
        ]
    ShelleyGenesisHashMismatch GenesisHashShelley
actual GenesisHashShelley
expected ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Wrong Shelley genesis file: the actual hash is "
        , Hash Blake2b_256 ByteString -> Text
renderHash (GenesisHashShelley -> Hash Blake2b_256 ByteString
unGenesisHashShelley GenesisHashShelley
actual)
        , Text
", but the expected Shelley genesis hash given in the node "
        , Text
"configuration file is "
        , Hash Blake2b_256 ByteString -> Text
renderHash (GenesisHashShelley -> Hash Blake2b_256 ByteString
unGenesisHashShelley GenesisHashShelley
expected)
        , Text
"."
        ]
    ShelleyGenesisDecodeError String
fp Text
err ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"There was an error parsing the genesis file: "
        , String -> Text
Text.pack String
fp
        , Text
" Error: "
        , Text
err
        ]

readAlonzoGenesis
  :: forall m t era
   . MonadIOTransError AlonzoGenesisError t m
  => Maybe (CardanoEra era)
  -- ^ Provide era witness to read Alonzo Genesis in an era-sensitive manner (see
  -- 'Cardano.Api.Genesis.decodeAlonzGenesis' for more details)
  -> File AlonzoGenesis 'In
  -> GenesisHashAlonzo
  -> t m AlonzoGenesis
readAlonzoGenesis :: forall (m :: * -> *) (t :: (* -> *) -> * -> *) era.
MonadIOTransError AlonzoGenesisError t m =>
Maybe (CardanoEra era)
-> File AlonzoGenesis 'In -> GenesisHashAlonzo -> t m AlonzoGenesis
readAlonzoGenesis Maybe (CardanoEra era)
mEra (File String
file) GenesisHashAlonzo
expectedGenesisHash = do
  ByteString
content <-
    (AlonzoGenesisError -> AlonzoGenesisError)
-> ExceptT AlonzoGenesisError m ByteString -> t m ByteString
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError AlonzoGenesisError -> AlonzoGenesisError
forall a. a -> a
id (ExceptT AlonzoGenesisError m ByteString -> t m ByteString)
-> ExceptT AlonzoGenesisError m ByteString -> t m ByteString
forall a b. (a -> b) -> a -> b
$ (IOException -> AlonzoGenesisError)
-> IO ByteString -> ExceptT AlonzoGenesisError m ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (String -> Text -> AlonzoGenesisError
AlonzoGenesisReadError String
file (Text -> AlonzoGenesisError)
-> (IOException -> Text) -> IOException -> AlonzoGenesisError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> Text
forall a. Show a => a -> Text
textShow) (IO ByteString -> ExceptT AlonzoGenesisError m ByteString)
-> IO ByteString -> ExceptT AlonzoGenesisError m ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
LBS.readFile String
file
  let genesisHash :: GenesisHashAlonzo
genesisHash = Hash Blake2b_256 ByteString -> GenesisHashAlonzo
GenesisHashAlonzo (Hash Blake2b_256 ByteString -> GenesisHashAlonzo)
-> (ByteString -> Hash Blake2b_256 ByteString)
-> ByteString
-> GenesisHashAlonzo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString)
-> ByteString -> Hash Blake2b_256 ByteString
forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Cardano.Crypto.Hash.Class.hashWith ByteString -> ByteString
forall a. a -> a
id (ByteString -> GenesisHashAlonzo)
-> ByteString -> GenesisHashAlonzo
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
content
  GenesisHashAlonzo -> t m ()
checkExpectedGenesisHash GenesisHashAlonzo
genesisHash
  (String -> AlonzoGenesisError)
-> ExceptT String m AlonzoGenesis -> t m AlonzoGenesis
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError (String -> Text -> AlonzoGenesisError
AlonzoGenesisDecodeError String
file (Text -> AlonzoGenesisError)
-> (String -> Text) -> String -> AlonzoGenesisError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) (ExceptT String m AlonzoGenesis -> t m AlonzoGenesis)
-> ExceptT String m AlonzoGenesis -> t m AlonzoGenesis
forall a b. (a -> b) -> a -> b
$
    Maybe (CardanoEra era)
-> ByteString -> ExceptT String m AlonzoGenesis
forall era (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadTransError String t m =>
Maybe (CardanoEra era) -> ByteString -> t m AlonzoGenesis
decodeAlonzoGenesis Maybe (CardanoEra era)
mEra ByteString
content
 where
  checkExpectedGenesisHash :: GenesisHashAlonzo -> t m ()
  checkExpectedGenesisHash :: GenesisHashAlonzo -> t m ()
checkExpectedGenesisHash GenesisHashAlonzo
actual =
    Bool -> t m () -> t m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GenesisHashAlonzo
actual GenesisHashAlonzo -> GenesisHashAlonzo -> Bool
forall a. Eq a => a -> a -> Bool
/= GenesisHashAlonzo
expectedGenesisHash) (t m () -> t m ()) -> t m () -> t m ()
forall a b. (a -> b) -> a -> b
$
      AlonzoGenesisError -> t m ()
forall a. AlonzoGenesisError -> t m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GenesisHashAlonzo -> GenesisHashAlonzo -> AlonzoGenesisError
AlonzoGenesisHashMismatch GenesisHashAlonzo
actual GenesisHashAlonzo
expectedGenesisHash)

data AlonzoGenesisError
  = AlonzoGenesisReadError !FilePath !Text
  | AlonzoGenesisHashMismatch !GenesisHashAlonzo !GenesisHashAlonzo -- actual, expected
  | AlonzoGenesisDecodeError !FilePath !Text
  deriving Int -> AlonzoGenesisError -> ShowS
[AlonzoGenesisError] -> ShowS
AlonzoGenesisError -> String
(Int -> AlonzoGenesisError -> ShowS)
-> (AlonzoGenesisError -> String)
-> ([AlonzoGenesisError] -> ShowS)
-> Show AlonzoGenesisError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AlonzoGenesisError -> ShowS
showsPrec :: Int -> AlonzoGenesisError -> ShowS
$cshow :: AlonzoGenesisError -> String
show :: AlonzoGenesisError -> String
$cshowList :: [AlonzoGenesisError] -> ShowS
showList :: [AlonzoGenesisError] -> ShowS
Show

instance Exception AlonzoGenesisError

renderAlonzoGenesisError :: AlonzoGenesisError -> Text
renderAlonzoGenesisError :: AlonzoGenesisError -> Text
renderAlonzoGenesisError AlonzoGenesisError
sge =
  case AlonzoGenesisError
sge of
    AlonzoGenesisReadError String
fp Text
err ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"There was an error reading the genesis file: "
        , String -> Text
Text.pack String
fp
        , Text
" Error: "
        , Text
err
        ]
    AlonzoGenesisHashMismatch GenesisHashAlonzo
actual GenesisHashAlonzo
expected ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Wrong Alonzo genesis file: the actual hash is "
        , Hash Blake2b_256 ByteString -> Text
renderHash (GenesisHashAlonzo -> Hash Blake2b_256 ByteString
unGenesisHashAlonzo GenesisHashAlonzo
actual)
        , Text
", but the expected Alonzo genesis hash given in the node "
        , Text
"configuration file is "
        , Hash Blake2b_256 ByteString -> Text
renderHash (GenesisHashAlonzo -> Hash Blake2b_256 ByteString
unGenesisHashAlonzo GenesisHashAlonzo
expected)
        , Text
"."
        ]
    AlonzoGenesisDecodeError String
fp Text
err ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"There was an error parsing the genesis file: "
        , String -> Text
Text.pack String
fp
        , Text
" Error: "
        , Text
err
        ]

readConwayGenesis
  :: forall m t
   . MonadIOTransError ConwayGenesisError t m
  => Maybe (ConwayGenesisFile 'In)
  -> Maybe GenesisHashConway
  -> t m (ConwayGenesis Consensus.StandardCrypto)
readConwayGenesis :: forall (m :: * -> *) (t :: (* -> *) -> * -> *).
MonadIOTransError ConwayGenesisError t m =>
Maybe (File ConwayGenesisConfig 'In)
-> Maybe GenesisHashConway -> t m ConwayGenesisConfig
readConwayGenesis Maybe (File ConwayGenesisConfig 'In)
Nothing Maybe GenesisHashConway
Nothing = ConwayGenesisConfig -> t m ConwayGenesisConfig
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return ConwayGenesisConfig
conwayGenesisDefaults
readConwayGenesis (Just File ConwayGenesisConfig 'In
fp) Maybe GenesisHashConway
Nothing = ConwayGenesisError -> t m ConwayGenesisConfig
forall a. ConwayGenesisError -> t m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ConwayGenesisError -> t m ConwayGenesisConfig)
-> ConwayGenesisError -> t m ConwayGenesisConfig
forall a b. (a -> b) -> a -> b
$ String -> ConwayGenesisError
ConwayGenesisHashMissing (String -> ConwayGenesisError) -> String -> ConwayGenesisError
forall a b. (a -> b) -> a -> b
$ File ConwayGenesisConfig 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
unFile File ConwayGenesisConfig 'In
fp
readConwayGenesis Maybe (File ConwayGenesisConfig 'In)
Nothing (Just GenesisHashConway
_) = ConwayGenesisError -> t m ConwayGenesisConfig
forall a. ConwayGenesisError -> t m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ConwayGenesisError
ConwayGenesisFileMissing
readConwayGenesis (Just (File String
file)) (Just GenesisHashConway
expectedGenesisHash) = do
  ByteString
content <-
    (ConwayGenesisError -> ConwayGenesisError)
-> ExceptT ConwayGenesisError m ByteString -> t m ByteString
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError ConwayGenesisError -> ConwayGenesisError
forall a. a -> a
id (ExceptT ConwayGenesisError m ByteString -> t m ByteString)
-> ExceptT ConwayGenesisError m ByteString -> t m ByteString
forall a b. (a -> b) -> a -> b
$ (IOException -> ConwayGenesisError)
-> IO ByteString -> ExceptT ConwayGenesisError m ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (String -> Text -> ConwayGenesisError
ConwayGenesisReadError String
file (Text -> ConwayGenesisError)
-> (IOException -> Text) -> IOException -> ConwayGenesisError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> Text
forall a. Show a => a -> Text
textShow) (IO ByteString -> ExceptT ConwayGenesisError m ByteString)
-> IO ByteString -> ExceptT ConwayGenesisError m ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
file
  let genesisHash :: GenesisHashConway
genesisHash = Hash Blake2b_256 ByteString -> GenesisHashConway
GenesisHashConway ((ByteString -> ByteString)
-> ByteString -> Hash Blake2b_256 ByteString
forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Cardano.Crypto.Hash.Class.hashWith ByteString -> ByteString
forall a. a -> a
id ByteString
content)
  GenesisHashConway -> t m ()
checkExpectedGenesisHash GenesisHashConway
genesisHash
  Either ConwayGenesisError ConwayGenesisConfig
-> t m ConwayGenesisConfig
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either ConwayGenesisError ConwayGenesisConfig
 -> t m ConwayGenesisConfig)
-> (Either String ConwayGenesisConfig
    -> Either ConwayGenesisError ConwayGenesisConfig)
-> Either String ConwayGenesisConfig
-> t m ConwayGenesisConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ConwayGenesisError)
-> Either String ConwayGenesisConfig
-> Either ConwayGenesisError ConwayGenesisConfig
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text -> ConwayGenesisError
ConwayGenesisDecodeError String
file (Text -> ConwayGenesisError)
-> (String -> Text) -> String -> ConwayGenesisError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack) (Either String ConwayGenesisConfig -> t m ConwayGenesisConfig)
-> Either String ConwayGenesisConfig -> t m ConwayGenesisConfig
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ConwayGenesisConfig
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict' ByteString
content
 where
  checkExpectedGenesisHash :: GenesisHashConway -> t m ()
  checkExpectedGenesisHash :: GenesisHashConway -> t m ()
checkExpectedGenesisHash GenesisHashConway
actual =
    Bool -> t m () -> t m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GenesisHashConway
actual GenesisHashConway -> GenesisHashConway -> Bool
forall a. Eq a => a -> a -> Bool
/= GenesisHashConway
expectedGenesisHash) (t m () -> t m ()) -> t m () -> t m ()
forall a b. (a -> b) -> a -> b
$
      ConwayGenesisError -> t m ()
forall a. ConwayGenesisError -> t m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GenesisHashConway -> GenesisHashConway -> ConwayGenesisError
ConwayGenesisHashMismatch GenesisHashConway
actual GenesisHashConway
expectedGenesisHash)

data ConwayGenesisError
  = ConwayGenesisReadError !FilePath !Text
  | ConwayGenesisHashMismatch !GenesisHashConway !GenesisHashConway -- actual, expected
  | ConwayGenesisHashMissing !FilePath
  | ConwayGenesisFileMissing
  | ConwayGenesisDecodeError !FilePath !Text
  deriving Int -> ConwayGenesisError -> ShowS
[ConwayGenesisError] -> ShowS
ConwayGenesisError -> String
(Int -> ConwayGenesisError -> ShowS)
-> (ConwayGenesisError -> String)
-> ([ConwayGenesisError] -> ShowS)
-> Show ConwayGenesisError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConwayGenesisError -> ShowS
showsPrec :: Int -> ConwayGenesisError -> ShowS
$cshow :: ConwayGenesisError -> String
show :: ConwayGenesisError -> String
$cshowList :: [ConwayGenesisError] -> ShowS
showList :: [ConwayGenesisError] -> ShowS
Show

instance Exception ConwayGenesisError

renderConwayGenesisError :: ConwayGenesisError -> Text
renderConwayGenesisError :: ConwayGenesisError -> Text
renderConwayGenesisError ConwayGenesisError
sge =
  case ConwayGenesisError
sge of
    ConwayGenesisError
ConwayGenesisFileMissing ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"\"ConwayGenesisFile\" is missing from node configuration. "
        ]
    ConwayGenesisHashMissing String
fp ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"\"ConwayGenesisHash\" is missing from node configuration: "
        , String -> Text
Text.pack String
fp
        ]
    ConwayGenesisReadError String
fp Text
err ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"There was an error reading the genesis file: "
        , String -> Text
Text.pack String
fp
        , Text
" Error: "
        , Text
err
        ]
    ConwayGenesisHashMismatch GenesisHashConway
actual GenesisHashConway
expected ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Wrong Conway genesis file: the actual hash is "
        , Hash Blake2b_256 ByteString -> Text
renderHash (GenesisHashConway -> Hash Blake2b_256 ByteString
unGenesisHashConway GenesisHashConway
actual)
        , Text
", but the expected Conway genesis hash given in the node "
        , Text
"configuration file is "
        , Hash Blake2b_256 ByteString -> Text
renderHash (GenesisHashConway -> Hash Blake2b_256 ByteString
unGenesisHashConway GenesisHashConway
expected)
        , Text
"."
        ]
    ConwayGenesisDecodeError String
fp Text
err ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"There was an error parsing the genesis file: "
        , String -> Text
Text.pack String
fp
        , Text
" Error: "
        , Text
err
        ]

renderHash
  :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 ByteString -> Text
renderHash :: Hash Blake2b_256 ByteString -> Text
renderHash Hash Blake2b_256 ByteString
h = ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Base16.encode (Hash Blake2b_256 ByteString -> ByteString
forall h a. Hash h a -> ByteString
Cardano.Crypto.Hash.Class.hashToBytes Hash Blake2b_256 ByteString
h)

newtype StakeCred = StakeCred {StakeCred -> Credential 'Staking StandardCrypto
_unStakeCred :: Ledger.Credential 'Ledger.Staking Consensus.StandardCrypto}
  deriving (StakeCred -> StakeCred -> Bool
(StakeCred -> StakeCred -> Bool)
-> (StakeCred -> StakeCred -> Bool) -> Eq StakeCred
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StakeCred -> StakeCred -> Bool
== :: StakeCred -> StakeCred -> Bool
$c/= :: StakeCred -> StakeCred -> Bool
/= :: StakeCred -> StakeCred -> Bool
Eq, Eq StakeCred
Eq StakeCred =>
(StakeCred -> StakeCred -> Ordering)
-> (StakeCred -> StakeCred -> Bool)
-> (StakeCred -> StakeCred -> Bool)
-> (StakeCred -> StakeCred -> Bool)
-> (StakeCred -> StakeCred -> Bool)
-> (StakeCred -> StakeCred -> StakeCred)
-> (StakeCred -> StakeCred -> StakeCred)
-> Ord StakeCred
StakeCred -> StakeCred -> Bool
StakeCred -> StakeCred -> Ordering
StakeCred -> StakeCred -> StakeCred
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StakeCred -> StakeCred -> Ordering
compare :: StakeCred -> StakeCred -> Ordering
$c< :: StakeCred -> StakeCred -> Bool
< :: StakeCred -> StakeCred -> Bool
$c<= :: StakeCred -> StakeCred -> Bool
<= :: StakeCred -> StakeCred -> Bool
$c> :: StakeCred -> StakeCred -> Bool
> :: StakeCred -> StakeCred -> Bool
$c>= :: StakeCred -> StakeCred -> Bool
>= :: StakeCred -> StakeCred -> Bool
$cmax :: StakeCred -> StakeCred -> StakeCred
max :: StakeCred -> StakeCred -> StakeCred
$cmin :: StakeCred -> StakeCred -> StakeCred
min :: StakeCred -> StakeCred -> StakeCred
Ord)

data Env = Env
  { Env -> CardanoLedgerConfig StandardCrypto
envLedgerConfig :: Consensus.CardanoLedgerConfig Consensus.StandardCrypto
  , Env -> CardanoConsensusConfig StandardCrypto
envConsensusConfig :: Consensus.CardanoConsensusConfig Consensus.StandardCrypto
  }

envSecurityParam :: Env -> Word64
envSecurityParam :: Env -> Word64
envSecurityParam Env
env = Word64
k
 where
  Consensus.SecurityParam Word64
k =
    CardanoConsensusConfig StandardCrypto -> SecurityParam
forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> SecurityParam
HFC.hardForkConsensusConfigK (CardanoConsensusConfig StandardCrypto -> SecurityParam)
-> CardanoConsensusConfig StandardCrypto -> SecurityParam
forall a b. (a -> b) -> a -> b
$
      Env -> CardanoConsensusConfig StandardCrypto
envConsensusConfig Env
env

-- | How to do validation when applying a block to a ledger state.
data ValidationMode
  = -- | Do all validation implied by the ledger layer's 'applyBlock`.
    FullValidation
  | -- | Only check that the previous hash from the block matches the head hash of
    -- the ledger state.
    QuickValidation

-- The function 'tickThenReapply' does zero validation, so add minimal
-- validation ('blockPrevHash' matches the tip hash of the 'LedgerState'). This
-- was originally for debugging but the check is cheap enough to keep.
applyBlock'
  :: Env
  -> LedgerState
  -> ValidationMode
  -> Consensus.CardanoBlock Consensus.StandardCrypto
  -> Either LedgerStateError LedgerStateEvents
applyBlock' :: Env
-> LedgerState
-> ValidationMode
-> CardanoBlock StandardCrypto
-> Either LedgerStateError LedgerStateEvents
applyBlock' Env
env LedgerState
oldState ValidationMode
validationMode CardanoBlock StandardCrypto
block = do
  let config :: CardanoLedgerConfig StandardCrypto
config = Env -> CardanoLedgerConfig StandardCrypto
envLedgerConfig Env
env
      stateOld :: CardanoLedgerState StandardCrypto
stateOld = LedgerState -> CardanoLedgerState StandardCrypto
clsState LedgerState
oldState
  case ValidationMode
validationMode of
    ValidationMode
FullValidation -> CardanoLedgerConfig StandardCrypto
-> CardanoBlock StandardCrypto
-> CardanoLedgerState StandardCrypto
-> Either LedgerStateError LedgerStateEvents
tickThenApply CardanoLedgerConfig StandardCrypto
config CardanoBlock StandardCrypto
block CardanoLedgerState StandardCrypto
stateOld
    ValidationMode
QuickValidation -> CardanoLedgerConfig StandardCrypto
-> CardanoBlock StandardCrypto
-> CardanoLedgerState StandardCrypto
-> Either LedgerStateError LedgerStateEvents
tickThenReapplyCheckHash CardanoLedgerConfig StandardCrypto
config CardanoBlock StandardCrypto
block CardanoLedgerState StandardCrypto
stateOld

applyBlockWithEvents
  :: Env
  -> LedgerState
  -> Bool
  -- ^ True to validate
  -> Consensus.CardanoBlock Consensus.StandardCrypto
  -> Either LedgerStateError LedgerStateEvents
applyBlockWithEvents :: Env
-> LedgerState
-> Bool
-> CardanoBlock StandardCrypto
-> Either LedgerStateError LedgerStateEvents
applyBlockWithEvents Env
env LedgerState
oldState Bool
enableValidation CardanoBlock StandardCrypto
block = do
  let config :: CardanoLedgerConfig StandardCrypto
config = Env -> CardanoLedgerConfig StandardCrypto
envLedgerConfig Env
env
      stateOld :: CardanoLedgerState StandardCrypto
stateOld = LedgerState -> CardanoLedgerState StandardCrypto
clsState LedgerState
oldState
  if Bool
enableValidation
    then CardanoLedgerConfig StandardCrypto
-> CardanoBlock StandardCrypto
-> CardanoLedgerState StandardCrypto
-> Either LedgerStateError LedgerStateEvents
tickThenApply CardanoLedgerConfig StandardCrypto
config CardanoBlock StandardCrypto
block CardanoLedgerState StandardCrypto
stateOld
    else CardanoLedgerConfig StandardCrypto
-> CardanoBlock StandardCrypto
-> CardanoLedgerState StandardCrypto
-> Either LedgerStateError LedgerStateEvents
tickThenReapplyCheckHash CardanoLedgerConfig StandardCrypto
config CardanoBlock StandardCrypto
block CardanoLedgerState StandardCrypto
stateOld

-- Like 'Consensus.tickThenReapply' but also checks that the previous hash from
-- the block matches the head hash of the ledger state.
tickThenReapplyCheckHash
  :: Consensus.CardanoLedgerConfig Consensus.StandardCrypto
  -> Consensus.CardanoBlock Consensus.StandardCrypto
  -> Consensus.CardanoLedgerState Consensus.StandardCrypto
  -> Either LedgerStateError LedgerStateEvents
tickThenReapplyCheckHash :: CardanoLedgerConfig StandardCrypto
-> CardanoBlock StandardCrypto
-> CardanoLedgerState StandardCrypto
-> Either LedgerStateError LedgerStateEvents
tickThenReapplyCheckHash CardanoLedgerConfig StandardCrypto
cfg CardanoBlock StandardCrypto
block CardanoLedgerState StandardCrypto
lsb =
  if CardanoBlock StandardCrypto
-> ChainHash (CardanoBlock StandardCrypto)
forall blk. GetPrevHash blk => blk -> ChainHash blk
Consensus.blockPrevHash CardanoBlock StandardCrypto
block ChainHash (CardanoBlock StandardCrypto)
-> ChainHash (CardanoBlock StandardCrypto) -> Bool
forall a. Eq a => a -> a -> Bool
== CardanoLedgerState StandardCrypto
-> ChainHash (CardanoBlock StandardCrypto)
forall blk. UpdateLedger blk => LedgerState blk -> ChainHash blk
Ledger.ledgerTipHash CardanoLedgerState StandardCrypto
lsb
    then
      LedgerStateEvents -> Either LedgerStateError LedgerStateEvents
forall a b. b -> Either a b
Right (LedgerStateEvents -> Either LedgerStateError LedgerStateEvents)
-> (LedgerResult
      (CardanoLedgerState StandardCrypto)
      (CardanoLedgerState StandardCrypto)
    -> LedgerStateEvents)
-> LedgerResult
     (CardanoLedgerState StandardCrypto)
     (CardanoLedgerState StandardCrypto)
-> Either LedgerStateError LedgerStateEvents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerResult
  (CardanoLedgerState StandardCrypto)
  (CardanoLedgerState StandardCrypto)
-> LedgerStateEvents
toLedgerStateEvents (LedgerResult
   (CardanoLedgerState StandardCrypto)
   (CardanoLedgerState StandardCrypto)
 -> Either LedgerStateError LedgerStateEvents)
-> LedgerResult
     (CardanoLedgerState StandardCrypto)
     (CardanoLedgerState StandardCrypto)
-> Either LedgerStateError LedgerStateEvents
forall a b. (a -> b) -> a -> b
$
        LedgerConfig (CardanoBlock StandardCrypto)
-> CardanoBlock StandardCrypto
-> CardanoLedgerState StandardCrypto
-> LedgerResult
     (CardanoLedgerState StandardCrypto)
     (CardanoLedgerState StandardCrypto)
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> LedgerResult l l
Ledger.tickThenReapplyLedgerResult LedgerConfig (CardanoBlock StandardCrypto)
CardanoLedgerConfig StandardCrypto
cfg CardanoBlock StandardCrypto
block CardanoLedgerState StandardCrypto
lsb
    else
      LedgerStateError -> Either LedgerStateError LedgerStateEvents
forall a b. a -> Either a b
Left (LedgerStateError -> Either LedgerStateError LedgerStateEvents)
-> LedgerStateError -> Either LedgerStateError LedgerStateEvents
forall a b. (a -> b) -> a -> b
$
        Text -> LedgerStateError
ApplyBlockHashMismatch (Text -> LedgerStateError) -> Text -> LedgerStateError
forall a b. (a -> b) -> a -> b
$
          [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Ledger state hash mismatch. Ledger head is slot "
            , Word64 -> Text
forall a. Show a => a -> Text
textShow (Word64 -> Text) -> Word64 -> Text
forall a b. (a -> b) -> a -> b
$
                SlotNo -> Word64
Slot.unSlotNo (SlotNo -> Word64) -> SlotNo -> Word64
forall a b. (a -> b) -> a -> b
$
                  SlotNo -> WithOrigin SlotNo -> SlotNo
forall t. t -> WithOrigin t -> t
Slot.fromWithOrigin
                    (Word64 -> SlotNo
Slot.SlotNo Word64
0)
                    (CardanoLedgerState StandardCrypto -> WithOrigin SlotNo
forall blk.
UpdateLedger blk =>
LedgerState blk -> WithOrigin SlotNo
Ledger.ledgerTipSlot CardanoLedgerState StandardCrypto
lsb)
            , Text
" hash "
            , ByteString -> Text
forall bin. ByteArrayAccess bin => bin -> Text
renderByteArray (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$
                ChainHash (CardanoBlock StandardCrypto) -> ByteString
forall era. ChainHash (CardanoBlock era) -> ByteString
unChainHash (ChainHash (CardanoBlock StandardCrypto) -> ByteString)
-> ChainHash (CardanoBlock StandardCrypto) -> ByteString
forall a b. (a -> b) -> a -> b
$
                  CardanoLedgerState StandardCrypto
-> ChainHash (CardanoBlock StandardCrypto)
forall blk. UpdateLedger blk => LedgerState blk -> ChainHash blk
Ledger.ledgerTipHash CardanoLedgerState StandardCrypto
lsb
            , Text
" but block previous hash is "
            , ByteString -> Text
forall bin. ByteArrayAccess bin => bin -> Text
renderByteArray (ChainHash (CardanoBlock StandardCrypto) -> ByteString
forall era. ChainHash (CardanoBlock era) -> ByteString
unChainHash (ChainHash (CardanoBlock StandardCrypto) -> ByteString)
-> ChainHash (CardanoBlock StandardCrypto) -> ByteString
forall a b. (a -> b) -> a -> b
$ CardanoBlock StandardCrypto
-> ChainHash (CardanoBlock StandardCrypto)
forall blk. GetPrevHash blk => blk -> ChainHash blk
Consensus.blockPrevHash CardanoBlock StandardCrypto
block)
            , Text
" and block current hash is "
            , ByteString -> Text
forall bin. ByteArrayAccess bin => bin -> Text
renderByteArray (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$
                ShortByteString -> ByteString
BSS.fromShort (ShortByteString -> ByteString) -> ShortByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
                  OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto)
-> ShortByteString
forall k (xs :: [k]). OneEraHash xs -> ShortByteString
HFC.getOneEraHash (OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto)
 -> ShortByteString)
-> OneEraHash (ByronBlock : CardanoShelleyEras StandardCrypto)
-> ShortByteString
forall a b. (a -> b) -> a -> b
$
                    CardanoBlock StandardCrypto
-> HeaderHash (CardanoBlock StandardCrypto)
forall b. HasHeader b => b -> HeaderHash b
Ouroboros.Network.Block.blockHash CardanoBlock StandardCrypto
block
            , Text
"."
            ]

-- Like 'Consensus.tickThenReapply' but also checks that the previous hash from
-- the block matches the head hash of the ledger state.
tickThenApply
  :: Consensus.CardanoLedgerConfig Consensus.StandardCrypto
  -> Consensus.CardanoBlock Consensus.StandardCrypto
  -> Consensus.CardanoLedgerState Consensus.StandardCrypto
  -> Either LedgerStateError LedgerStateEvents
tickThenApply :: CardanoLedgerConfig StandardCrypto
-> CardanoBlock StandardCrypto
-> CardanoLedgerState StandardCrypto
-> Either LedgerStateError LedgerStateEvents
tickThenApply CardanoLedgerConfig StandardCrypto
cfg CardanoBlock StandardCrypto
block CardanoLedgerState StandardCrypto
lsb =
  (CardanoLedgerError StandardCrypto
 -> Either LedgerStateError LedgerStateEvents)
-> (LedgerResult
      (CardanoLedgerState StandardCrypto)
      (CardanoLedgerState StandardCrypto)
    -> Either LedgerStateError LedgerStateEvents)
-> Either
     (CardanoLedgerError StandardCrypto)
     (LedgerResult
        (CardanoLedgerState StandardCrypto)
        (CardanoLedgerState StandardCrypto))
-> Either LedgerStateError LedgerStateEvents
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (LedgerStateError -> Either LedgerStateError LedgerStateEvents
forall a b. a -> Either a b
Left (LedgerStateError -> Either LedgerStateError LedgerStateEvents)
-> (CardanoLedgerError StandardCrypto -> LedgerStateError)
-> CardanoLedgerError StandardCrypto
-> Either LedgerStateError LedgerStateEvents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoLedgerError StandardCrypto -> LedgerStateError
ApplyBlockError) (LedgerStateEvents -> Either LedgerStateError LedgerStateEvents
forall a b. b -> Either a b
Right (LedgerStateEvents -> Either LedgerStateError LedgerStateEvents)
-> (LedgerResult
      (CardanoLedgerState StandardCrypto)
      (CardanoLedgerState StandardCrypto)
    -> LedgerStateEvents)
-> LedgerResult
     (CardanoLedgerState StandardCrypto)
     (CardanoLedgerState StandardCrypto)
-> Either LedgerStateError LedgerStateEvents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerResult
  (CardanoLedgerState StandardCrypto)
  (CardanoLedgerState StandardCrypto)
-> LedgerStateEvents
toLedgerStateEvents) (Either
   (CardanoLedgerError StandardCrypto)
   (LedgerResult
      (CardanoLedgerState StandardCrypto)
      (CardanoLedgerState StandardCrypto))
 -> Either LedgerStateError LedgerStateEvents)
-> Either
     (CardanoLedgerError StandardCrypto)
     (LedgerResult
        (CardanoLedgerState StandardCrypto)
        (CardanoLedgerState StandardCrypto))
-> Either LedgerStateError LedgerStateEvents
forall a b. (a -> b) -> a -> b
$
    Except
  (CardanoLedgerError StandardCrypto)
  (LedgerResult
     (CardanoLedgerState StandardCrypto)
     (CardanoLedgerState StandardCrypto))
-> Either
     (CardanoLedgerError StandardCrypto)
     (LedgerResult
        (CardanoLedgerState StandardCrypto)
        (CardanoLedgerState StandardCrypto))
forall e a. Except e a -> Either e a
runExcept (Except
   (CardanoLedgerError StandardCrypto)
   (LedgerResult
      (CardanoLedgerState StandardCrypto)
      (CardanoLedgerState StandardCrypto))
 -> Either
      (CardanoLedgerError StandardCrypto)
      (LedgerResult
         (CardanoLedgerState StandardCrypto)
         (CardanoLedgerState StandardCrypto)))
-> Except
     (CardanoLedgerError StandardCrypto)
     (LedgerResult
        (CardanoLedgerState StandardCrypto)
        (CardanoLedgerState StandardCrypto))
-> Either
     (CardanoLedgerError StandardCrypto)
     (LedgerResult
        (CardanoLedgerState StandardCrypto)
        (CardanoLedgerState StandardCrypto))
forall a b. (a -> b) -> a -> b
$
      LedgerConfig (CardanoBlock StandardCrypto)
-> CardanoBlock StandardCrypto
-> CardanoLedgerState StandardCrypto
-> Except
     (LedgerErr (CardanoLedgerState StandardCrypto))
     (LedgerResult
        (CardanoLedgerState StandardCrypto)
        (CardanoLedgerState StandardCrypto))
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) (LedgerResult l l)
Ledger.tickThenApplyLedgerResult LedgerConfig (CardanoBlock StandardCrypto)
CardanoLedgerConfig StandardCrypto
cfg CardanoBlock StandardCrypto
block CardanoLedgerState StandardCrypto
lsb

renderByteArray :: ByteArrayAccess bin => bin -> Text
renderByteArray :: forall bin. ByteArrayAccess bin => bin -> Text
renderByteArray =
  ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> (bin -> ByteString) -> bin -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> ByteString)
-> (bin -> ByteString) -> bin -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. bin -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
Data.ByteArray.convert

unChainHash :: Ouroboros.Network.Block.ChainHash (Consensus.CardanoBlock era) -> ByteString
unChainHash :: forall era. ChainHash (CardanoBlock era) -> ByteString
unChainHash ChainHash (CardanoBlock era)
ch =
  case ChainHash (CardanoBlock era)
ch of
    ChainHash (CardanoBlock era)
Ouroboros.Network.Block.GenesisHash -> ByteString
"genesis"
    Ouroboros.Network.Block.BlockHash HeaderHash (CardanoBlock era)
bh -> ShortByteString -> ByteString
BSS.fromShort (OneEraHash (ByronBlock : CardanoShelleyEras era) -> ShortByteString
forall k (xs :: [k]). OneEraHash xs -> ShortByteString
HFC.getOneEraHash HeaderHash (CardanoBlock era)
OneEraHash (ByronBlock : CardanoShelleyEras era)
bh)

data LeadershipError
  = LeaderErrDecodeLedgerStateFailure
  | LeaderErrDecodeProtocolStateFailure (LBS.ByteString, DecoderError)
  | LeaderErrDecodeProtocolEpochStateFailure DecoderError
  | LeaderErrGenesisSlot
  | LeaderErrStakePoolHasNoStake PoolId
  | LeaderErrStakeDistribUnstable
      SlotNo
      -- ^ Current slot
      SlotNo
      -- ^ Stable after
      SlotNo
      -- ^ Stability window size
      SlotNo
      -- ^ Predicted last slot of the epoch
  | LeaderErrSlotRangeCalculationFailure Text
  | LeaderErrCandidateNonceStillEvolving
  deriving Int -> LeadershipError -> ShowS
[LeadershipError] -> ShowS
LeadershipError -> String
(Int -> LeadershipError -> ShowS)
-> (LeadershipError -> String)
-> ([LeadershipError] -> ShowS)
-> Show LeadershipError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LeadershipError -> ShowS
showsPrec :: Int -> LeadershipError -> ShowS
$cshow :: LeadershipError -> String
show :: LeadershipError -> String
$cshowList :: [LeadershipError] -> ShowS
showList :: [LeadershipError] -> ShowS
Show

instance Api.Error LeadershipError where
  prettyError :: forall ann. LeadershipError -> Doc ann
prettyError = \case
    LeadershipError
LeaderErrDecodeLedgerStateFailure ->
      Doc ann
"Failed to successfully decode ledger state"
    LeaderErrDecodeProtocolStateFailure (ByteString
_, DecoderError
decErr) ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
        [ Doc ann
"Failed to successfully decode protocol state: "
        , Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (LazyText -> Text
LT.toStrict (LazyText -> Text) -> (Builder -> LazyText) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyText
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ DecoderError -> Builder
forall p. Buildable p => p -> Builder
build DecoderError
decErr)
        ]
    LeadershipError
LeaderErrGenesisSlot ->
      Doc ann
"Leadership schedule currently cannot be calculated from genesis"
    LeaderErrStakePoolHasNoStake PoolId
poolId ->
      Doc ann
"The stake pool: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> PoolId -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow PoolId
poolId Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" has no stake"
    LeaderErrDecodeProtocolEpochStateFailure DecoderError
decoderError ->
      Doc ann
"Failed to successfully decode the current epoch state: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> DecoderError -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow DecoderError
decoderError
    LeaderErrStakeDistribUnstable SlotNo
curSlot SlotNo
stableAfterSlot SlotNo
stabWindow SlotNo
predictedLastSlot ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
        [ Doc ann
"The current stake distribution is currently unstable and therefore we cannot predict "
        , Doc ann
"the following epoch's leadership schedule. Please wait until : " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> SlotNo -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow SlotNo
stableAfterSlot
        , Doc ann
" before running the leadership-schedule command again. \nCurrent slot: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> SlotNo -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow SlotNo
curSlot
        , Doc ann
" \nStability window: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> SlotNo -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow SlotNo
stabWindow
        , Doc ann
" \nCalculated last slot of current epoch: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> SlotNo -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow SlotNo
predictedLastSlot
        ]
    LeaderErrSlotRangeCalculationFailure Text
e ->
      Doc ann
"Error while calculating the slot range: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
e
    LeadershipError
LeaderErrCandidateNonceStillEvolving ->
      Doc ann
"Candidate nonce is still evolving"

nextEpochEligibleLeadershipSlots
  :: forall era
   . ()
  => ShelleyBasedEra era
  -> ShelleyGenesis Consensus.StandardCrypto
  -> SerialisedCurrentEpochState era
  -- ^ We need the mark stake distribution in order to predict
  --   the following epoch's leadership schedule
  -> ProtocolState era
  -> PoolId
  -- ^ Potential slot leading stake pool
  -> SigningKey VrfKey
  -- ^ VRF signing key of the stake pool
  -> Ledger.PParams (ShelleyLedgerEra era)
  -> EpochInfo (Either Text)
  -> (ChainTip, EpochNo)
  -> Either LeadershipError (Set SlotNo)
nextEpochEligibleLeadershipSlots :: forall era.
ShelleyBasedEra era
-> ShelleyGenesis StandardCrypto
-> SerialisedCurrentEpochState era
-> ProtocolState era
-> PoolId
-> SigningKey VrfKey
-> PParams (ShelleyLedgerEra era)
-> EpochInfo (Either Text)
-> (ChainTip, EpochNo)
-> Either LeadershipError (Set SlotNo)
nextEpochEligibleLeadershipSlots ShelleyBasedEra era
sbe ShelleyGenesis StandardCrypto
sGen SerialisedCurrentEpochState era
serCurrEpochState ProtocolState era
ptclState PoolId
poolid (VrfSigningKey SignKeyVRF StandardCrypto
vrfSkey) PParams (ShelleyLedgerEra era)
pp EpochInfo (Either Text)
eInfo (ChainTip
cTip, EpochNo
currentEpoch) =
  ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era =>
    Either LeadershipError (Set SlotNo))
-> Either LeadershipError (Set SlotNo)
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
sbe ((ShelleyBasedEraConstraints era =>
  Either LeadershipError (Set SlotNo))
 -> Either LeadershipError (Set SlotNo))
-> (ShelleyBasedEraConstraints era =>
    Either LeadershipError (Set SlotNo))
-> Either LeadershipError (Set SlotNo)
forall a b. (a -> b) -> a -> b
$ do
    (SlotNo
_, SlotNo
currentEpochLastSlot) <-
      (Text -> LeadershipError)
-> Either Text (SlotNo, SlotNo)
-> Either LeadershipError (SlotNo, SlotNo)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> LeadershipError
LeaderErrSlotRangeCalculationFailure (Either Text (SlotNo, SlotNo)
 -> Either LeadershipError (SlotNo, SlotNo))
-> Either Text (SlotNo, SlotNo)
-> Either LeadershipError (SlotNo, SlotNo)
forall a b. (a -> b) -> a -> b
$
        EpochInfo (Either Text) -> EpochNo -> Either Text (SlotNo, SlotNo)
forall (m :: * -> *).
Monad m =>
EpochInfo m -> EpochNo -> m (SlotNo, SlotNo)
Slot.epochInfoRange EpochInfo (Either Text)
eInfo EpochNo
currentEpoch

    (SlotNo
firstSlotOfEpoch, SlotNo
lastSlotofEpoch) <-
      (Text -> LeadershipError)
-> Either Text (SlotNo, SlotNo)
-> Either LeadershipError (SlotNo, SlotNo)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> LeadershipError
LeaderErrSlotRangeCalculationFailure (Either Text (SlotNo, SlotNo)
 -> Either LeadershipError (SlotNo, SlotNo))
-> Either Text (SlotNo, SlotNo)
-> Either LeadershipError (SlotNo, SlotNo)
forall a b. (a -> b) -> a -> b
$
        EpochInfo (Either Text) -> EpochNo -> Either Text (SlotNo, SlotNo)
forall (m :: * -> *).
Monad m =>
EpochInfo m -> EpochNo -> m (SlotNo, SlotNo)
Slot.epochInfoRange EpochInfo (Either Text)
eInfo (EpochNo
currentEpoch EpochNo -> EpochInterval -> EpochNo
`Slot.addEpochInterval` Word32 -> EpochInterval
Slot.EpochInterval Word32
1)

    -- First we check if we are within 3k/f slots of the end of the current epoch.
    -- In Conway era onwards, we use 4k/f slots instead of 3k/f slots.
    -- see: https://ouroboros-consensus.cardano.intersectmbo.org/docs/for-developers/Glossary#epoch-structure
    -- Why? Because the stake distribution is stable at this point.
    -- k is the security parameter
    -- f is the active slot coefficient
    let stabilityWindowR :: Rational
        stabilityWindowR :: Rational
stabilityWindowR =
          Word64 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
stabilityWindowConst Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* ShelleyGenesis StandardCrypto -> Word64
forall c. ShelleyGenesis c -> Word64
sgSecurityParam ShelleyGenesis StandardCrypto
sGen)
            Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ PositiveUnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
Ledger.unboundRational (ShelleyGenesis StandardCrypto -> PositiveUnitInterval
forall c. ShelleyGenesis c -> PositiveUnitInterval
sgActiveSlotsCoeff ShelleyGenesis StandardCrypto
sGen)
        stabilityWindowSlots :: SlotNo
        stabilityWindowSlots :: SlotNo
stabilityWindowSlots = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word64 (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Double -> Word64
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Word64) -> Double -> Word64
forall a b. (a -> b) -> a -> b
$ forall a. Fractional a => Rational -> a
fromRational @Double Rational
stabilityWindowR
        stableStakeDistribSlot :: SlotNo
stableStakeDistribSlot = SlotNo
currentEpochLastSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
stabilityWindowSlots
        stabilityWindowConst :: Word64
stabilityWindowConst = (ShelleyToBabbageEraConstraints era =>
 ShelleyToBabbageEra era -> Word64)
-> (ConwayEraOnwardsConstraints era =>
    ConwayEraOnwards era -> Word64)
-> ShelleyBasedEra era
-> Word64
forall era a.
(ShelleyToBabbageEraConstraints era =>
 ShelleyToBabbageEra era -> a)
-> (ConwayEraOnwardsConstraints era => ConwayEraOnwards era -> a)
-> ShelleyBasedEra era
-> a
caseShelleyToBabbageOrConwayEraOnwards (Word64 -> ShelleyToBabbageEra era -> Word64
forall a b. a -> b -> a
const Word64
3) (Word64 -> ConwayEraOnwards era -> Word64
forall a b. a -> b -> a
const Word64
4) ShelleyBasedEra era
sbe

    case ChainTip
cTip of
      ChainTip
ChainTipAtGenesis -> LeadershipError -> Either LeadershipError ()
forall a b. a -> Either a b
Left LeadershipError
LeaderErrGenesisSlot
      ChainTip SlotNo
tip Hash BlockHeader
_ BlockNo
_ ->
        if SlotNo
tip SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
stableStakeDistribSlot
          then () -> Either LeadershipError ()
forall a. a -> Either LeadershipError a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else
            LeadershipError -> Either LeadershipError ()
forall a b. a -> Either a b
Left (LeadershipError -> Either LeadershipError ())
-> LeadershipError -> Either LeadershipError ()
forall a b. (a -> b) -> a -> b
$
              SlotNo -> SlotNo -> SlotNo -> SlotNo -> LeadershipError
LeaderErrStakeDistribUnstable SlotNo
tip SlotNo
stableStakeDistribSlot SlotNo
stabilityWindowSlots SlotNo
currentEpochLastSlot

    ChainDepState (ConsensusProtocol era)
chainDepState <-
      ((ByteString, DecoderError) -> LeadershipError)
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
-> Either LeadershipError (ChainDepState (ConsensusProtocol era))
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ByteString, DecoderError) -> LeadershipError
LeaderErrDecodeProtocolStateFailure (Either
   (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
 -> Either LeadershipError (ChainDepState (ConsensusProtocol era)))
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
-> Either LeadershipError (ChainDepState (ConsensusProtocol era))
forall a b. (a -> b) -> a -> b
$
        ProtocolState era
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
forall era.
FromCBOR (ChainDepState (ConsensusProtocol era)) =>
ProtocolState era
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
decodeProtocolState ProtocolState era
ptclState

    -- We need the candidate nonce, the previous epoch's last block header hash
    -- and the extra entropy from the protocol parameters. We then need to combine them
    -- with the (⭒) operator.
    let Consensus.PraosNonces{Nonce
candidateNonce :: Nonce
candidateNonce :: PraosNonces -> Nonce
Consensus.candidateNonce, Nonce
evolvingNonce :: Nonce
evolvingNonce :: PraosNonces -> Nonce
Consensus.evolvingNonce} =
          Proxy (ConsensusProtocol era)
-> ChainDepState (ConsensusProtocol era) -> PraosNonces
forall p (proxy :: * -> *).
PraosProtocolSupportsNode p =>
proxy p -> ChainDepState p -> PraosNonces
forall (proxy :: * -> *).
proxy (ConsensusProtocol era)
-> ChainDepState (ConsensusProtocol era) -> PraosNonces
Consensus.getPraosNonces (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Api.ConsensusProtocol era)) ChainDepState (ConsensusProtocol era)
chainDepState

    -- Let's do a nonce check. The candidate nonce and the evolving nonce should not be equal.
    Bool -> Either LeadershipError () -> Either LeadershipError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Nonce
evolvingNonce Nonce -> Nonce -> Bool
forall a. Eq a => a -> a -> Bool
== Nonce
candidateNonce) (Either LeadershipError () -> Either LeadershipError ())
-> Either LeadershipError () -> Either LeadershipError ()
forall a b. (a -> b) -> a -> b
$
      LeadershipError -> Either LeadershipError ()
forall a b. a -> Either a b
Left LeadershipError
LeaderErrCandidateNonceStillEvolving

    -- Get the previous epoch's last block header hash nonce
    let previousLabNonce :: Nonce
previousLabNonce =
          PraosNonces -> Nonce
Consensus.previousLabNonce
            (Proxy (ConsensusProtocol era)
-> ChainDepState (ConsensusProtocol era) -> PraosNonces
forall p (proxy :: * -> *).
PraosProtocolSupportsNode p =>
proxy p -> ChainDepState p -> PraosNonces
forall (proxy :: * -> *).
proxy (ConsensusProtocol era)
-> ChainDepState (ConsensusProtocol era) -> PraosNonces
Consensus.getPraosNonces (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Api.ConsensusProtocol era)) ChainDepState (ConsensusProtocol era)
chainDepState)
        extraEntropy :: Nonce
        extraEntropy :: Nonce
extraEntropy =
          (ShelleyToAlonzoEraConstraints era =>
 ShelleyToAlonzoEra era -> Nonce)
-> (BabbageEraOnwardsConstraints era =>
    BabbageEraOnwards era -> Nonce)
-> ShelleyBasedEra era
-> Nonce
forall era a.
(ShelleyToAlonzoEraConstraints era => ShelleyToAlonzoEra era -> a)
-> (BabbageEraOnwardsConstraints era => BabbageEraOnwards era -> a)
-> ShelleyBasedEra era
-> a
caseShelleyToAlonzoOrBabbageEraOnwards
            (Nonce -> ShelleyToAlonzoEra era -> Nonce
forall a b. a -> b -> a
const (PParams (ShelleyLedgerEra era)
pp PParams (ShelleyLedgerEra era)
-> Getting Nonce (PParams (ShelleyLedgerEra era)) Nonce -> Nonce
forall s a. s -> Getting a s a -> a
^. Getting Nonce (PParams (ShelleyLedgerEra era)) Nonce
forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) Nonce
Lens' (PParams (ShelleyLedgerEra era)) Nonce
Core.ppExtraEntropyL))
            (Nonce -> BabbageEraOnwards era -> Nonce
forall a b. a -> b -> a
const Nonce
Ledger.NeutralNonce)
            ShelleyBasedEra era
sbe

        nextEpochsNonce :: Nonce
nextEpochsNonce = Nonce
candidateNonce Nonce -> Nonce -> Nonce
⭒ Nonce
previousLabNonce Nonce -> Nonce -> Nonce
⭒ Nonce
extraEntropy

    -- Then we get the "mark" snapshot. This snapshot will be used for the next
    -- epoch's leadership schedule.
    CurrentEpochState EpochState (ShelleyLedgerEra era)
cEstate <-
      (DecoderError -> LeadershipError)
-> Either DecoderError (CurrentEpochState era)
-> Either LeadershipError (CurrentEpochState era)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DecoderError -> LeadershipError
LeaderErrDecodeProtocolEpochStateFailure (Either DecoderError (CurrentEpochState era)
 -> Either LeadershipError (CurrentEpochState era))
-> Either DecoderError (CurrentEpochState era)
-> Either LeadershipError (CurrentEpochState era)
forall a b. (a -> b) -> a -> b
$
        ShelleyBasedEra era
-> SerialisedCurrentEpochState era
-> Either DecoderError (CurrentEpochState era)
forall era.
ShelleyBasedEra era
-> SerialisedCurrentEpochState era
-> Either DecoderError (CurrentEpochState era)
decodeCurrentEpochState ShelleyBasedEra era
sbe SerialisedCurrentEpochState era
serCurrEpochState

    let snapshot :: ShelleyAPI.SnapShot Consensus.StandardCrypto
        snapshot :: SnapShot StandardCrypto
snapshot = SnapShots StandardCrypto -> SnapShot StandardCrypto
forall c. SnapShots c -> SnapShot c
ShelleyAPI.ssStakeMark (SnapShots StandardCrypto -> SnapShot StandardCrypto)
-> SnapShots StandardCrypto -> SnapShot StandardCrypto
forall a b. (a -> b) -> a -> b
$ EpochState (ShelleyLedgerEra era)
-> SnapShots (EraCrypto (ShelleyLedgerEra era))
forall era. EpochState era -> SnapShots (EraCrypto era)
ShelleyAPI.esSnapshots EpochState (ShelleyLedgerEra era)
cEstate
        markSnapshotPoolDistr
          :: Map
              (SL.KeyHash 'SL.StakePool Consensus.StandardCrypto)
              (SL.IndividualPoolStake Consensus.StandardCrypto)
        markSnapshotPoolDistr :: Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
markSnapshotPoolDistr = PoolDistr StandardCrypto
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
forall c.
PoolDistr c -> Map (KeyHash 'StakePool c) (IndividualPoolStake c)
ShelleyAPI.unPoolDistr (PoolDistr StandardCrypto
 -> Map
      (KeyHash 'StakePool StandardCrypto)
      (IndividualPoolStake StandardCrypto))
-> (SnapShot StandardCrypto -> PoolDistr StandardCrypto)
-> SnapShot StandardCrypto
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapShot StandardCrypto -> PoolDistr StandardCrypto
forall c. SnapShot c -> PoolDistr c
ShelleyAPI.calculatePoolDistr (SnapShot StandardCrypto
 -> Map
      (KeyHash 'StakePool StandardCrypto)
      (IndividualPoolStake StandardCrypto))
-> SnapShot StandardCrypto
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
forall a b. (a -> b) -> a -> b
$ SnapShot StandardCrypto
snapshot

    let slotRangeOfInterest :: Core.EraPParams ledgerera => Core.PParams ledgerera -> Set SlotNo
        slotRangeOfInterest :: forall ledgerera.
EraPParams ledgerera =>
PParams ledgerera -> Set SlotNo
slotRangeOfInterest PParams ledgerera
pp' =
          (SlotNo -> Bool) -> Set SlotNo -> Set SlotNo
forall a. (a -> Bool) -> Set a -> Set a
Set.filter
            (Bool -> Bool
not (Bool -> Bool) -> (SlotNo -> Bool) -> SlotNo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> UnitInterval -> SlotNo -> Bool
Ledger.isOverlaySlot SlotNo
firstSlotOfEpoch (PParams ledgerera
pp' PParams ledgerera
-> Getting UnitInterval (PParams ledgerera) UnitInterval
-> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams ledgerera) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams ledgerera) UnitInterval
Core.ppDG))
            (Set SlotNo -> Set SlotNo) -> Set SlotNo -> Set SlotNo
forall a b. (a -> b) -> a -> b
$ [Item (Set SlotNo)] -> Set SlotNo
forall l. IsList l => [Item l] -> l
fromList [Item (Set SlotNo)
SlotNo
firstSlotOfEpoch .. Item (Set SlotNo)
SlotNo
lastSlotofEpoch]

    (ShelleyToAlonzoEraConstraints era =>
 ShelleyToAlonzoEra era -> Either LeadershipError (Set SlotNo))
-> (BabbageEraOnwardsConstraints era =>
    BabbageEraOnwards era -> Either LeadershipError (Set SlotNo))
-> ShelleyBasedEra era
-> Either LeadershipError (Set SlotNo)
forall era a.
(ShelleyToAlonzoEraConstraints era => ShelleyToAlonzoEra era -> a)
-> (BabbageEraOnwardsConstraints era => BabbageEraOnwards era -> a)
-> ShelleyBasedEra era
-> a
caseShelleyToAlonzoOrBabbageEraOnwards
      ( Either LeadershipError (Set SlotNo)
-> ShelleyToAlonzoEra era -> Either LeadershipError (Set SlotNo)
forall a b. a -> b -> a
const
          (Set SlotNo
-> PoolId
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
-> Nonce
-> SignKeyVRF PraosVRF
-> ActiveSlotCoeff
-> Either LeadershipError (Set SlotNo)
forall v.
(Signable v Seed, VRFAlgorithm v, ContextVRF v ~ ()) =>
Set SlotNo
-> PoolId
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
-> Nonce
-> SignKeyVRF v
-> ActiveSlotCoeff
-> Either LeadershipError (Set SlotNo)
isLeadingSlotsTPraos (PParams (ShelleyLedgerEra era) -> Set SlotNo
forall ledgerera.
EraPParams ledgerera =>
PParams ledgerera -> Set SlotNo
slotRangeOfInterest PParams (ShelleyLedgerEra era)
pp) PoolId
poolid Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
markSnapshotPoolDistr Nonce
nextEpochsNonce SignKeyVRF PraosVRF
SignKeyVRF StandardCrypto
vrfSkey ActiveSlotCoeff
f)
      )
      ( Either LeadershipError (Set SlotNo)
-> BabbageEraOnwards era -> Either LeadershipError (Set SlotNo)
forall a b. a -> b -> a
const
          (Set SlotNo
-> PoolId
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
-> Nonce
-> SignKeyVRF StandardCrypto
-> ActiveSlotCoeff
-> Either LeadershipError (Set SlotNo)
isLeadingSlotsPraos (PParams (ShelleyLedgerEra era) -> Set SlotNo
forall ledgerera.
EraPParams ledgerera =>
PParams ledgerera -> Set SlotNo
slotRangeOfInterest PParams (ShelleyLedgerEra era)
pp) PoolId
poolid Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
markSnapshotPoolDistr Nonce
nextEpochsNonce SignKeyVRF StandardCrypto
vrfSkey ActiveSlotCoeff
f)
      )
      ShelleyBasedEra era
sbe
 where
  globals :: Globals
globals = ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era => Globals) -> Globals
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
sbe ((ShelleyBasedEraConstraints era => Globals) -> Globals)
-> (ShelleyBasedEraConstraints era => Globals) -> Globals
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis StandardCrypto -> EpochInfo (Either Text) -> Globals
constructGlobals ShelleyGenesis StandardCrypto
sGen EpochInfo (Either Text)
eInfo

  f :: Ledger.ActiveSlotCoeff
  f :: ActiveSlotCoeff
f = Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
globals

-- | Return slots a given stake pool operator is leading.
-- See Leader Value Calculation in the Shelley ledger specification.
-- We need the certified natural value from the VRF, active slot coefficient
-- and the stake proportion of the stake pool.
isLeadingSlotsTPraos
  :: forall v
   . ()
  => Crypto.Signable v Ledger.Seed
  => Crypto.VRFAlgorithm v
  => Crypto.ContextVRF v ~ ()
  => Set SlotNo
  -> PoolId
  -> Map
      (SL.KeyHash 'SL.StakePool Consensus.StandardCrypto)
      (SL.IndividualPoolStake Consensus.StandardCrypto)
  -> Consensus.Nonce
  -> Crypto.SignKeyVRF v
  -> Ledger.ActiveSlotCoeff
  -> Either LeadershipError (Set SlotNo)
isLeadingSlotsTPraos :: forall v.
(Signable v Seed, VRFAlgorithm v, ContextVRF v ~ ()) =>
Set SlotNo
-> PoolId
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
-> Nonce
-> SignKeyVRF v
-> ActiveSlotCoeff
-> Either LeadershipError (Set SlotNo)
isLeadingSlotsTPraos Set SlotNo
slotRangeOfInterest PoolId
poolid Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
snapshotPoolDistr Nonce
eNonce SignKeyVRF v
vrfSkey ActiveSlotCoeff
activeSlotCoeff' = do
  let StakePoolKeyHash KeyHash 'StakePool StandardCrypto
poolHash = PoolId
poolid

  let certifiedVrf :: SlotNo -> CertifiedVRF v Seed
certifiedVrf SlotNo
s = ContextVRF v -> Seed -> SignKeyVRF v -> CertifiedVRF v Seed
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
Crypto.evalCertified () (Nonce -> SlotNo -> Nonce -> Seed
TPraos.mkSeed Nonce
TPraos.seedL SlotNo
s Nonce
eNonce) SignKeyVRF v
vrfSkey

  Rational
stakePoolStake <-
    IndividualPoolStake StandardCrypto -> Rational
forall c. IndividualPoolStake c -> Rational
ShelleyAPI.individualPoolStake
      (IndividualPoolStake StandardCrypto -> Rational)
-> Maybe (IndividualPoolStake StandardCrypto) -> Maybe Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool StandardCrypto
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
-> Maybe (IndividualPoolStake StandardCrypto)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool StandardCrypto
poolHash Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
snapshotPoolDistr
      Maybe Rational
-> (Maybe Rational -> Either LeadershipError Rational)
-> Either LeadershipError Rational
forall a b. a -> (a -> b) -> b
& LeadershipError
-> Maybe Rational -> Either LeadershipError Rational
forall a b. a -> Maybe b -> Either a b
note (PoolId -> LeadershipError
LeaderErrStakePoolHasNoStake PoolId
poolid)

  let isLeader :: SlotNo -> Bool
isLeader SlotNo
s = OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
forall v.
VRFAlgorithm v =>
OutputVRF v -> Rational -> ActiveSlotCoeff -> Bool
TPraos.checkLeaderValue (CertifiedVRF v Seed -> OutputVRF v
forall v a. CertifiedVRF v a -> OutputVRF v
Crypto.certifiedOutput (SlotNo -> CertifiedVRF v Seed
certifiedVrf SlotNo
s)) Rational
stakePoolStake ActiveSlotCoeff
activeSlotCoeff'

  Set SlotNo -> Either LeadershipError (Set SlotNo)
forall a. a -> Either LeadershipError a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set SlotNo -> Either LeadershipError (Set SlotNo))
-> Set SlotNo -> Either LeadershipError (Set SlotNo)
forall a b. (a -> b) -> a -> b
$ (SlotNo -> Bool) -> Set SlotNo -> Set SlotNo
forall a. (a -> Bool) -> Set a -> Set a
Set.filter SlotNo -> Bool
isLeader Set SlotNo
slotRangeOfInterest

isLeadingSlotsPraos
  :: ()
  => Set SlotNo
  -> PoolId
  -> Map
      (SL.KeyHash 'SL.StakePool Consensus.StandardCrypto)
      (SL.IndividualPoolStake Consensus.StandardCrypto)
  -> Consensus.Nonce
  -> SL.SignKeyVRF Consensus.StandardCrypto
  -> Ledger.ActiveSlotCoeff
  -> Either LeadershipError (Set SlotNo)
isLeadingSlotsPraos :: Set SlotNo
-> PoolId
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
-> Nonce
-> SignKeyVRF StandardCrypto
-> ActiveSlotCoeff
-> Either LeadershipError (Set SlotNo)
isLeadingSlotsPraos Set SlotNo
slotRangeOfInterest PoolId
poolid Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
snapshotPoolDistr Nonce
eNonce SignKeyVRF StandardCrypto
vrfSkey ActiveSlotCoeff
activeSlotCoeff' = do
  let StakePoolKeyHash KeyHash 'StakePool StandardCrypto
poolHash = PoolId
poolid

  Rational
stakePoolStake <-
    LeadershipError
-> Maybe Rational -> Either LeadershipError Rational
forall a b. a -> Maybe b -> Either a b
note (PoolId -> LeadershipError
LeaderErrStakePoolHasNoStake PoolId
poolid) (Maybe Rational -> Either LeadershipError Rational)
-> Maybe Rational -> Either LeadershipError Rational
forall a b. (a -> b) -> a -> b
$
      IndividualPoolStake StandardCrypto -> Rational
forall c. IndividualPoolStake c -> Rational
ShelleyAPI.individualPoolStake (IndividualPoolStake StandardCrypto -> Rational)
-> Maybe (IndividualPoolStake StandardCrypto) -> Maybe Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool StandardCrypto
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
-> Maybe (IndividualPoolStake StandardCrypto)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool StandardCrypto
poolHash Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
snapshotPoolDistr

  let isLeader :: SlotNo -> Bool
isLeader SlotNo
slotNo = BoundedNatural -> Rational -> ActiveSlotCoeff -> Bool
checkLeaderNatValue BoundedNatural
certifiedNatValue Rational
stakePoolStake ActiveSlotCoeff
activeSlotCoeff'
       where
        rho :: CertifiedVRF PraosVRF InputVRF
rho = ContextVRF PraosVRF
-> InputVRF
-> SignKeyVRF PraosVRF
-> CertifiedVRF PraosVRF InputVRF
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
VRF.evalCertified () (SlotNo -> Nonce -> InputVRF
mkInputVRF SlotNo
slotNo Nonce
eNonce) SignKeyVRF PraosVRF
SignKeyVRF StandardCrypto
vrfSkey
        certifiedNatValue :: BoundedNatural
certifiedNatValue = Proxy StandardCrypto
-> CertifiedVRF (VRF StandardCrypto) InputVRF -> BoundedNatural
forall c (proxy :: * -> *).
Crypto c =>
proxy c -> CertifiedVRF (VRF c) InputVRF -> BoundedNatural
vrfLeaderValue (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Consensus.StandardCrypto) CertifiedVRF PraosVRF InputVRF
CertifiedVRF (VRF StandardCrypto) InputVRF
rho

  Set SlotNo -> Either LeadershipError (Set SlotNo)
forall a b. b -> Either a b
Right (Set SlotNo -> Either LeadershipError (Set SlotNo))
-> Set SlotNo -> Either LeadershipError (Set SlotNo)
forall a b. (a -> b) -> a -> b
$ (SlotNo -> Bool) -> Set SlotNo -> Set SlotNo
forall a. (a -> Bool) -> Set a -> Set a
Set.filter SlotNo -> Bool
isLeader Set SlotNo
slotRangeOfInterest

-- | Return the slots at which a particular stake pool operator is
-- expected to mint a block.
currentEpochEligibleLeadershipSlots
  :: forall era
   . ()
  => ShelleyBasedEra era
  -> ShelleyGenesis Consensus.StandardCrypto
  -> EpochInfo (Either Text)
  -> Ledger.PParams (ShelleyLedgerEra era)
  -> ProtocolState era
  -> PoolId
  -> SigningKey VrfKey
  -> SerialisedPoolDistribution era
  -> EpochNo
  -- ^ Current EpochInfo
  -> Either LeadershipError (Set SlotNo)
currentEpochEligibleLeadershipSlots :: forall era.
ShelleyBasedEra era
-> ShelleyGenesis StandardCrypto
-> EpochInfo (Either Text)
-> PParams (ShelleyLedgerEra era)
-> ProtocolState era
-> PoolId
-> SigningKey VrfKey
-> SerialisedPoolDistribution era
-> EpochNo
-> Either LeadershipError (Set SlotNo)
currentEpochEligibleLeadershipSlots ShelleyBasedEra era
sbe ShelleyGenesis StandardCrypto
sGen EpochInfo (Either Text)
eInfo PParams (ShelleyLedgerEra era)
pp ProtocolState era
ptclState PoolId
poolid (VrfSigningKey SignKeyVRF StandardCrypto
vrkSkey) SerialisedPoolDistribution era
serPoolDistr EpochNo
currentEpoch =
  ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era =>
    Either LeadershipError (Set SlotNo))
-> Either LeadershipError (Set SlotNo)
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
sbe ((ShelleyBasedEraConstraints era =>
  Either LeadershipError (Set SlotNo))
 -> Either LeadershipError (Set SlotNo))
-> (ShelleyBasedEraConstraints era =>
    Either LeadershipError (Set SlotNo))
-> Either LeadershipError (Set SlotNo)
forall a b. (a -> b) -> a -> b
$ do
    ChainDepState (ConsensusProtocol era)
chainDepState :: ChainDepState (Api.ConsensusProtocol era) <-
      ((ByteString, DecoderError) -> LeadershipError)
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
-> Either LeadershipError (ChainDepState (ConsensusProtocol era))
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ByteString, DecoderError) -> LeadershipError
LeaderErrDecodeProtocolStateFailure (Either
   (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
 -> Either LeadershipError (ChainDepState (ConsensusProtocol era)))
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
-> Either LeadershipError (ChainDepState (ConsensusProtocol era))
forall a b. (a -> b) -> a -> b
$ ProtocolState era
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
forall era.
FromCBOR (ChainDepState (ConsensusProtocol era)) =>
ProtocolState era
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
decodeProtocolState ProtocolState era
ptclState

    -- We use the current epoch's nonce for the current leadership schedule
    -- calculation because the TICKN transition updates the epoch nonce
    -- at the start of the epoch.
    let Nonce
epochNonce :: Nonce =
          PraosNonces -> Nonce
Consensus.epochNonce (Proxy (ConsensusProtocol era)
-> ChainDepState (ConsensusProtocol era) -> PraosNonces
forall p (proxy :: * -> *).
PraosProtocolSupportsNode p =>
proxy p -> ChainDepState p -> PraosNonces
forall (proxy :: * -> *).
proxy (ConsensusProtocol era)
-> ChainDepState (ConsensusProtocol era) -> PraosNonces
Consensus.getPraosNonces (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Api.ConsensusProtocol era)) ChainDepState (ConsensusProtocol era)
chainDepState)

    (SlotNo
firstSlotOfEpoch, SlotNo
lastSlotofEpoch) :: (SlotNo, SlotNo) <-
      (Text -> LeadershipError)
-> Either Text (SlotNo, SlotNo)
-> Either LeadershipError (SlotNo, SlotNo)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> LeadershipError
LeaderErrSlotRangeCalculationFailure (Either Text (SlotNo, SlotNo)
 -> Either LeadershipError (SlotNo, SlotNo))
-> Either Text (SlotNo, SlotNo)
-> Either LeadershipError (SlotNo, SlotNo)
forall a b. (a -> b) -> a -> b
$
        EpochInfo (Either Text) -> EpochNo -> Either Text (SlotNo, SlotNo)
forall (m :: * -> *).
Monad m =>
EpochInfo m -> EpochNo -> m (SlotNo, SlotNo)
Slot.epochInfoRange EpochInfo (Either Text)
eInfo EpochNo
currentEpoch

    Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
setSnapshotPoolDistr <-
      (DecoderError -> LeadershipError)
-> Either
     DecoderError
     (Map
        (KeyHash 'StakePool StandardCrypto)
        (IndividualPoolStake StandardCrypto))
-> Either
     LeadershipError
     (Map
        (KeyHash 'StakePool StandardCrypto)
        (IndividualPoolStake StandardCrypto))
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DecoderError -> LeadershipError
LeaderErrDecodeProtocolEpochStateFailure
        (Either
   DecoderError
   (Map
      (KeyHash 'StakePool StandardCrypto)
      (IndividualPoolStake StandardCrypto))
 -> Either
      LeadershipError
      (Map
         (KeyHash 'StakePool StandardCrypto)
         (IndividualPoolStake StandardCrypto)))
-> (Either DecoderError (PoolDistribution era)
    -> Either
         DecoderError
         (Map
            (KeyHash 'StakePool StandardCrypto)
            (IndividualPoolStake StandardCrypto)))
-> Either DecoderError (PoolDistribution era)
-> Either
     LeadershipError
     (Map
        (KeyHash 'StakePool StandardCrypto)
        (IndividualPoolStake StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolDistribution era
 -> Map
      (KeyHash 'StakePool StandardCrypto)
      (IndividualPoolStake StandardCrypto))
-> Either DecoderError (PoolDistribution era)
-> Either
     DecoderError
     (Map
        (KeyHash 'StakePool StandardCrypto)
        (IndividualPoolStake StandardCrypto))
forall a b.
(a -> b) -> Either DecoderError a -> Either DecoderError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PoolDistr StandardCrypto
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
forall c.
PoolDistr c -> Map (KeyHash 'StakePool c) (IndividualPoolStake c)
SL.unPoolDistr (PoolDistr StandardCrypto
 -> Map
      (KeyHash 'StakePool StandardCrypto)
      (IndividualPoolStake StandardCrypto))
-> (PoolDistribution era -> PoolDistr StandardCrypto)
-> PoolDistribution era
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolDistr StandardCrypto -> PoolDistr StandardCrypto
forall c. PoolDistr c -> PoolDistr c
fromConsensusPoolDistr (PoolDistr StandardCrypto -> PoolDistr StandardCrypto)
-> (PoolDistribution era -> PoolDistr StandardCrypto)
-> PoolDistribution era
-> PoolDistr StandardCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolDistribution era
-> PoolDistr (EraCrypto (ShelleyLedgerEra era))
PoolDistribution era -> PoolDistr StandardCrypto
forall era.
PoolDistribution era
-> PoolDistr (EraCrypto (ShelleyLedgerEra era))
unPoolDistr)
        (Either DecoderError (PoolDistribution era)
 -> Either
      LeadershipError
      (Map
         (KeyHash 'StakePool StandardCrypto)
         (IndividualPoolStake StandardCrypto)))
-> Either DecoderError (PoolDistribution era)
-> Either
     LeadershipError
     (Map
        (KeyHash 'StakePool StandardCrypto)
        (IndividualPoolStake StandardCrypto))
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> SerialisedPoolDistribution era
-> Either DecoderError (PoolDistribution era)
forall era.
Crypto (EraCrypto (ShelleyLedgerEra era)) =>
ShelleyBasedEra era
-> SerialisedPoolDistribution era
-> Either DecoderError (PoolDistribution era)
decodePoolDistribution ShelleyBasedEra era
sbe SerialisedPoolDistribution era
serPoolDistr

    let slotRangeOfInterest :: Core.EraPParams ledgerera => Core.PParams ledgerera -> Set SlotNo
        slotRangeOfInterest :: forall ledgerera.
EraPParams ledgerera =>
PParams ledgerera -> Set SlotNo
slotRangeOfInterest PParams ledgerera
pp' =
          (SlotNo -> Bool) -> Set SlotNo -> Set SlotNo
forall a. (a -> Bool) -> Set a -> Set a
Set.filter
            (Bool -> Bool
not (Bool -> Bool) -> (SlotNo -> Bool) -> SlotNo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> UnitInterval -> SlotNo -> Bool
Ledger.isOverlaySlot SlotNo
firstSlotOfEpoch (PParams ledgerera
pp' PParams ledgerera
-> Getting UnitInterval (PParams ledgerera) UnitInterval
-> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams ledgerera) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams ledgerera) UnitInterval
Core.ppDG))
            (Set SlotNo -> Set SlotNo) -> Set SlotNo -> Set SlotNo
forall a b. (a -> b) -> a -> b
$ [Item (Set SlotNo)] -> Set SlotNo
forall l. IsList l => [Item l] -> l
fromList [Item (Set SlotNo)
SlotNo
firstSlotOfEpoch .. Item (Set SlotNo)
SlotNo
lastSlotofEpoch]

    (ShelleyToAlonzoEraConstraints era =>
 ShelleyToAlonzoEra era -> Either LeadershipError (Set SlotNo))
-> (BabbageEraOnwardsConstraints era =>
    BabbageEraOnwards era -> Either LeadershipError (Set SlotNo))
-> ShelleyBasedEra era
-> Either LeadershipError (Set SlotNo)
forall era a.
(ShelleyToAlonzoEraConstraints era => ShelleyToAlonzoEra era -> a)
-> (BabbageEraOnwardsConstraints era => BabbageEraOnwards era -> a)
-> ShelleyBasedEra era
-> a
caseShelleyToAlonzoOrBabbageEraOnwards
      ( Either LeadershipError (Set SlotNo)
-> ShelleyToAlonzoEra era -> Either LeadershipError (Set SlotNo)
forall a b. a -> b -> a
const
          (Set SlotNo
-> PoolId
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
-> Nonce
-> SignKeyVRF PraosVRF
-> ActiveSlotCoeff
-> Either LeadershipError (Set SlotNo)
forall v.
(Signable v Seed, VRFAlgorithm v, ContextVRF v ~ ()) =>
Set SlotNo
-> PoolId
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
-> Nonce
-> SignKeyVRF v
-> ActiveSlotCoeff
-> Either LeadershipError (Set SlotNo)
isLeadingSlotsTPraos (PParams (ShelleyLedgerEra era) -> Set SlotNo
forall ledgerera.
EraPParams ledgerera =>
PParams ledgerera -> Set SlotNo
slotRangeOfInterest PParams (ShelleyLedgerEra era)
pp) PoolId
poolid Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
setSnapshotPoolDistr Nonce
epochNonce SignKeyVRF PraosVRF
SignKeyVRF StandardCrypto
vrkSkey ActiveSlotCoeff
f)
      )
      ( Either LeadershipError (Set SlotNo)
-> BabbageEraOnwards era -> Either LeadershipError (Set SlotNo)
forall a b. a -> b -> a
const
          (Set SlotNo
-> PoolId
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
-> Nonce
-> SignKeyVRF StandardCrypto
-> ActiveSlotCoeff
-> Either LeadershipError (Set SlotNo)
isLeadingSlotsPraos (PParams (ShelleyLedgerEra era) -> Set SlotNo
forall ledgerera.
EraPParams ledgerera =>
PParams ledgerera -> Set SlotNo
slotRangeOfInterest PParams (ShelleyLedgerEra era)
pp) PoolId
poolid Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
setSnapshotPoolDistr Nonce
epochNonce SignKeyVRF StandardCrypto
vrkSkey ActiveSlotCoeff
f)
      )
      ShelleyBasedEra era
sbe
 where
  globals :: Globals
globals = ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era => Globals) -> Globals
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
sbe ((ShelleyBasedEraConstraints era => Globals) -> Globals)
-> (ShelleyBasedEraConstraints era => Globals) -> Globals
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis StandardCrypto -> EpochInfo (Either Text) -> Globals
constructGlobals ShelleyGenesis StandardCrypto
sGen EpochInfo (Either Text)
eInfo

  f :: Ledger.ActiveSlotCoeff
  f :: ActiveSlotCoeff
f = Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
globals

-- TODO remove me?
constructGlobals
  :: ShelleyGenesis Consensus.StandardCrypto
  -> EpochInfo (Either Text)
  -> Globals
constructGlobals :: ShelleyGenesis StandardCrypto -> EpochInfo (Either Text) -> Globals
constructGlobals = ShelleyGenesis StandardCrypto -> EpochInfo (Either Text) -> Globals
forall c. ShelleyGenesis c -> EpochInfo (Either Text) -> Globals
Ledger.mkShelleyGlobals

--------------------------------------------------------------------------

-- | Type isomorphic to bool, representing condition check result
data ConditionResult
  = ConditionNotMet
  | ConditionMet
  deriving (ReadPrec [ConditionResult]
ReadPrec ConditionResult
Int -> ReadS ConditionResult
ReadS [ConditionResult]
(Int -> ReadS ConditionResult)
-> ReadS [ConditionResult]
-> ReadPrec ConditionResult
-> ReadPrec [ConditionResult]
-> Read ConditionResult
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ConditionResult
readsPrec :: Int -> ReadS ConditionResult
$creadList :: ReadS [ConditionResult]
readList :: ReadS [ConditionResult]
$creadPrec :: ReadPrec ConditionResult
readPrec :: ReadPrec ConditionResult
$creadListPrec :: ReadPrec [ConditionResult]
readListPrec :: ReadPrec [ConditionResult]
Read, Int -> ConditionResult -> ShowS
[ConditionResult] -> ShowS
ConditionResult -> String
(Int -> ConditionResult -> ShowS)
-> (ConditionResult -> String)
-> ([ConditionResult] -> ShowS)
-> Show ConditionResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConditionResult -> ShowS
showsPrec :: Int -> ConditionResult -> ShowS
$cshow :: ConditionResult -> String
show :: ConditionResult -> String
$cshowList :: [ConditionResult] -> ShowS
showList :: [ConditionResult] -> ShowS
Show, Int -> ConditionResult
ConditionResult -> Int
ConditionResult -> [ConditionResult]
ConditionResult -> ConditionResult
ConditionResult -> ConditionResult -> [ConditionResult]
ConditionResult
-> ConditionResult -> ConditionResult -> [ConditionResult]
(ConditionResult -> ConditionResult)
-> (ConditionResult -> ConditionResult)
-> (Int -> ConditionResult)
-> (ConditionResult -> Int)
-> (ConditionResult -> [ConditionResult])
-> (ConditionResult -> ConditionResult -> [ConditionResult])
-> (ConditionResult -> ConditionResult -> [ConditionResult])
-> (ConditionResult
    -> ConditionResult -> ConditionResult -> [ConditionResult])
-> Enum ConditionResult
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ConditionResult -> ConditionResult
succ :: ConditionResult -> ConditionResult
$cpred :: ConditionResult -> ConditionResult
pred :: ConditionResult -> ConditionResult
$ctoEnum :: Int -> ConditionResult
toEnum :: Int -> ConditionResult
$cfromEnum :: ConditionResult -> Int
fromEnum :: ConditionResult -> Int
$cenumFrom :: ConditionResult -> [ConditionResult]
enumFrom :: ConditionResult -> [ConditionResult]
$cenumFromThen :: ConditionResult -> ConditionResult -> [ConditionResult]
enumFromThen :: ConditionResult -> ConditionResult -> [ConditionResult]
$cenumFromTo :: ConditionResult -> ConditionResult -> [ConditionResult]
enumFromTo :: ConditionResult -> ConditionResult -> [ConditionResult]
$cenumFromThenTo :: ConditionResult
-> ConditionResult -> ConditionResult -> [ConditionResult]
enumFromThenTo :: ConditionResult
-> ConditionResult -> ConditionResult -> [ConditionResult]
Enum, ConditionResult
ConditionResult -> ConditionResult -> Bounded ConditionResult
forall a. a -> a -> Bounded a
$cminBound :: ConditionResult
minBound :: ConditionResult
$cmaxBound :: ConditionResult
maxBound :: ConditionResult
Bounded, Eq ConditionResult
Eq ConditionResult =>
(ConditionResult -> ConditionResult -> Ordering)
-> (ConditionResult -> ConditionResult -> Bool)
-> (ConditionResult -> ConditionResult -> Bool)
-> (ConditionResult -> ConditionResult -> Bool)
-> (ConditionResult -> ConditionResult -> Bool)
-> (ConditionResult -> ConditionResult -> ConditionResult)
-> (ConditionResult -> ConditionResult -> ConditionResult)
-> Ord ConditionResult
ConditionResult -> ConditionResult -> Bool
ConditionResult -> ConditionResult -> Ordering
ConditionResult -> ConditionResult -> ConditionResult
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ConditionResult -> ConditionResult -> Ordering
compare :: ConditionResult -> ConditionResult -> Ordering
$c< :: ConditionResult -> ConditionResult -> Bool
< :: ConditionResult -> ConditionResult -> Bool
$c<= :: ConditionResult -> ConditionResult -> Bool
<= :: ConditionResult -> ConditionResult -> Bool
$c> :: ConditionResult -> ConditionResult -> Bool
> :: ConditionResult -> ConditionResult -> Bool
$c>= :: ConditionResult -> ConditionResult -> Bool
>= :: ConditionResult -> ConditionResult -> Bool
$cmax :: ConditionResult -> ConditionResult -> ConditionResult
max :: ConditionResult -> ConditionResult -> ConditionResult
$cmin :: ConditionResult -> ConditionResult -> ConditionResult
min :: ConditionResult -> ConditionResult -> ConditionResult
Ord, ConditionResult -> ConditionResult -> Bool
(ConditionResult -> ConditionResult -> Bool)
-> (ConditionResult -> ConditionResult -> Bool)
-> Eq ConditionResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConditionResult -> ConditionResult -> Bool
== :: ConditionResult -> ConditionResult -> Bool
$c/= :: ConditionResult -> ConditionResult -> Bool
/= :: ConditionResult -> ConditionResult -> Bool
Eq)

toConditionResult :: Bool -> ConditionResult
toConditionResult :: Bool -> ConditionResult
toConditionResult Bool
False = ConditionResult
ConditionNotMet
toConditionResult Bool
True = ConditionResult
ConditionMet

fromConditionResult :: ConditionResult -> Bool
fromConditionResult :: ConditionResult -> Bool
fromConditionResult ConditionResult
ConditionNotMet = Bool
False
fromConditionResult ConditionResult
ConditionMet = Bool
True

data AnyNewEpochState where
  AnyNewEpochState
    :: ShelleyBasedEra era
    -> ShelleyAPI.NewEpochState (ShelleyLedgerEra era)
    -> AnyNewEpochState

instance Show AnyNewEpochState where
  showsPrec :: Int -> AnyNewEpochState -> ShowS
showsPrec Int
p (AnyNewEpochState ShelleyBasedEra era
sbe NewEpochState (ShelleyLedgerEra era)
ledgerNewEpochState) =
    ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era => ShowS) -> ShowS
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
sbe ((ShelleyBasedEraConstraints era => ShowS) -> ShowS)
-> (ShelleyBasedEraConstraints era => ShowS) -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> NewEpochState (ShelleyLedgerEra era) -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p NewEpochState (ShelleyLedgerEra era)
ledgerNewEpochState

-- | Reconstructs the ledger's new epoch state and applies a supplied condition to it for every block. This
-- function only terminates if the condition is met or we have reached the termination epoch. We need to
-- provide a termination epoch otherwise blocks would be applied indefinitely.
foldEpochState
  :: forall t m s
   . MonadIOTransError FoldBlocksError t m
  => NodeConfigFile 'In
  -- ^ Path to the cardano-node config file (e.g. <path to cardano-node project>/configuration/cardano/mainnet-config.json)
  -> SocketPath
  -- ^ Path to local cardano-node socket. This is the path specified by the @--socket-path@ command line option when running the node.
  -> ValidationMode
  -> EpochNo
  -- ^ Termination epoch
  -> s
  -- ^ an initial value for the condition state
  -> ( AnyNewEpochState
       -> SlotNo
       -> BlockNo
       -> StateT s IO ConditionResult
     )
  -- ^ Condition you want to check against the new epoch state.
  --
  --   'SlotNo' - Current (not necessarily the tip) slot number
  --
  --   'BlockNo' - Current (not necessarily the tip) block number
  --
  -- Note: This function can safely assume no rollback will occur even though
  -- internally this is implemented with a client protocol that may require
  -- rollback. This is achieved by only calling the accumulator on states/blocks
  -- that are older than the security parameter, k. This has the side effect of
  -- truncating the last k blocks before the node's tip.
  -> t m (ConditionResult, s)
  -- ^ The final state
foldEpochState :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) s.
MonadIOTransError FoldBlocksError t m =>
NodeConfigFile 'In
-> SocketPath
-> ValidationMode
-> EpochNo
-> s
-> (AnyNewEpochState
    -> SlotNo -> BlockNo -> StateT s IO ConditionResult)
-> t m (ConditionResult, s)
foldEpochState NodeConfigFile 'In
nodeConfigFilePath SocketPath
socketPath ValidationMode
validationMode EpochNo
terminationEpoch s
initialResult AnyNewEpochState
-> SlotNo -> BlockNo -> StateT s IO ConditionResult
checkCondition = ExceptT FoldBlocksError IO (ConditionResult, s)
-> t m (ConditionResult, s)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadIOTransError FoldBlocksError t m =>
ExceptT FoldBlocksError IO a -> t m a
handleExceptions (ExceptT FoldBlocksError IO (ConditionResult, s)
 -> t m (ConditionResult, s))
-> ExceptT FoldBlocksError IO (ConditionResult, s)
-> t m (ConditionResult, s)
forall a b. (a -> b) -> a -> b
$ do
  -- NOTE this was originally implemented with a non-pipelined client then
  -- changed to a pipelined client for a modest speedup:
  --  * Non-pipelined: 1h  0m  19s
  --  * Pipelined:        46m  23s

  (Env
env, LedgerState
ledgerState) <-
    (InitialLedgerStateError -> FoldBlocksError)
-> ExceptT InitialLedgerStateError IO (Env, LedgerState)
-> ExceptT FoldBlocksError IO (Env, LedgerState)
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError InitialLedgerStateError -> FoldBlocksError
FoldBlocksInitialLedgerStateError (ExceptT InitialLedgerStateError IO (Env, LedgerState)
 -> ExceptT FoldBlocksError IO (Env, LedgerState))
-> ExceptT InitialLedgerStateError IO (Env, LedgerState)
-> ExceptT FoldBlocksError IO (Env, LedgerState)
forall a b. (a -> b) -> a -> b
$
      NodeConfigFile 'In
-> ExceptT InitialLedgerStateError IO (Env, LedgerState)
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadIOTransError InitialLedgerStateError t m =>
NodeConfigFile 'In -> t m (Env, LedgerState)
initialLedgerState NodeConfigFile 'In
nodeConfigFilePath

  -- Place to store the accumulated state
  -- This is a bit ugly, but easy.
  IORef (Maybe LedgerStateError)
errorIORef <- (IOException -> FoldBlocksError)
-> ExceptT IOException IO (IORef (Maybe LedgerStateError))
-> ExceptT FoldBlocksError IO (IORef (Maybe LedgerStateError))
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError IOException -> FoldBlocksError
FoldBlocksIOException (ExceptT IOException IO (IORef (Maybe LedgerStateError))
 -> ExceptT FoldBlocksError IO (IORef (Maybe LedgerStateError)))
-> (IO (IORef (Maybe LedgerStateError))
    -> ExceptT IOException IO (IORef (Maybe LedgerStateError)))
-> IO (IORef (Maybe LedgerStateError))
-> ExceptT FoldBlocksError IO (IORef (Maybe LedgerStateError))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (IORef (Maybe LedgerStateError))
-> ExceptT IOException IO (IORef (Maybe LedgerStateError))
forall a. IO a -> ExceptT IOException IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Maybe LedgerStateError))
 -> ExceptT FoldBlocksError IO (IORef (Maybe LedgerStateError)))
-> IO (IORef (Maybe LedgerStateError))
-> ExceptT FoldBlocksError IO (IORef (Maybe LedgerStateError))
forall a b. (a -> b) -> a -> b
$ Maybe LedgerStateError -> IO (IORef (Maybe LedgerStateError))
forall a. a -> IO (IORef a)
newIORef Maybe LedgerStateError
forall a. Maybe a
Nothing
  -- This needs to be a full MVar by default. It serves as a mutual exclusion lock when executing
  -- 'checkCondition' to ensure that states 's' are processed in order. This is assured by MVar fairness.
  MVar (ConditionResult, s)
stateMv <- (IOException -> FoldBlocksError)
-> ExceptT IOException IO (MVar (ConditionResult, s))
-> ExceptT FoldBlocksError IO (MVar (ConditionResult, s))
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError IOException -> FoldBlocksError
FoldBlocksIOException (ExceptT IOException IO (MVar (ConditionResult, s))
 -> ExceptT FoldBlocksError IO (MVar (ConditionResult, s)))
-> (IO (MVar (ConditionResult, s))
    -> ExceptT IOException IO (MVar (ConditionResult, s)))
-> IO (MVar (ConditionResult, s))
-> ExceptT FoldBlocksError IO (MVar (ConditionResult, s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (MVar (ConditionResult, s))
-> ExceptT IOException IO (MVar (ConditionResult, s))
forall a. IO a -> ExceptT IOException IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar (ConditionResult, s))
 -> ExceptT FoldBlocksError IO (MVar (ConditionResult, s)))
-> IO (MVar (ConditionResult, s))
-> ExceptT FoldBlocksError IO (MVar (ConditionResult, s))
forall a b. (a -> b) -> a -> b
$ (ConditionResult, s) -> IO (MVar (ConditionResult, s))
forall a. a -> IO (MVar a)
newMVar (ConditionResult
ConditionNotMet, s
initialResult)

  -- Derive the NetworkId as described in network-magic.md from the
  -- cardano-ledger-specs repo.
  let byronConfig :: Config
byronConfig =
        (\(Consensus.WrapPartialLedgerConfig (Consensus.ByronPartialLedgerConfig LedgerConfig ByronBlock
bc TriggerHardFork
_) :* NP WrapPartialLedgerConfig xs1
_) -> Config
LedgerConfig ByronBlock
bc)
          (NP
   WrapPartialLedgerConfig
   (ByronBlock : CardanoShelleyEras StandardCrypto)
 -> Config)
-> (CardanoLedgerConfig StandardCrypto
    -> NP
         WrapPartialLedgerConfig
         (ByronBlock : CardanoShelleyEras StandardCrypto))
-> CardanoLedgerConfig StandardCrypto
-> Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerEraLedgerConfig (ByronBlock : CardanoShelleyEras StandardCrypto)
-> NP
     WrapPartialLedgerConfig
     (ByronBlock : CardanoShelleyEras StandardCrypto)
forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
HFC.getPerEraLedgerConfig
          (PerEraLedgerConfig
   (ByronBlock : CardanoShelleyEras StandardCrypto)
 -> NP
      WrapPartialLedgerConfig
      (ByronBlock : CardanoShelleyEras StandardCrypto))
-> (CardanoLedgerConfig StandardCrypto
    -> PerEraLedgerConfig
         (ByronBlock : CardanoShelleyEras StandardCrypto))
-> CardanoLedgerConfig StandardCrypto
-> NP
     WrapPartialLedgerConfig
     (ByronBlock : CardanoShelleyEras StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoLedgerConfig StandardCrypto
-> PerEraLedgerConfig
     (ByronBlock : CardanoShelleyEras StandardCrypto)
forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
HFC.hardForkLedgerConfigPerEra
          (CardanoLedgerConfig StandardCrypto -> Config)
-> CardanoLedgerConfig StandardCrypto -> Config
forall a b. (a -> b) -> a -> b
$ Env -> CardanoLedgerConfig StandardCrypto
envLedgerConfig Env
env

      networkMagic :: NetworkMagic
networkMagic =
        Word32 -> NetworkMagic
NetworkMagic (Word32 -> NetworkMagic) -> Word32 -> NetworkMagic
forall a b. (a -> b) -> a -> b
$
          ProtocolMagicId -> Word32
unProtocolMagicId (ProtocolMagicId -> Word32) -> ProtocolMagicId -> Word32
forall a b. (a -> b) -> a -> b
$
            GenesisData -> ProtocolMagicId
Cardano.Chain.Genesis.gdProtocolMagicId (GenesisData -> ProtocolMagicId) -> GenesisData -> ProtocolMagicId
forall a b. (a -> b) -> a -> b
$
              Config -> GenesisData
Cardano.Chain.Genesis.configGenesisData Config
byronConfig

      networkId' :: NetworkId
networkId' = case Config -> RequiresNetworkMagic
Cardano.Chain.Genesis.configReqNetMagic Config
byronConfig of
        RequiresNetworkMagic
RequiresNoMagic -> NetworkId
Mainnet
        RequiresNetworkMagic
RequiresMagic -> NetworkMagic -> NetworkId
Testnet NetworkMagic
networkMagic

      cardanoModeParams :: ConsensusModeParams
cardanoModeParams = EpochSlots -> ConsensusModeParams
CardanoModeParams (EpochSlots -> ConsensusModeParams)
-> (Word64 -> EpochSlots) -> Word64 -> ConsensusModeParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> EpochSlots
EpochSlots (Word64 -> ConsensusModeParams) -> Word64 -> ConsensusModeParams
forall a b. (a -> b) -> a -> b
$ Word64
10 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Env -> Word64
envSecurityParam Env
env

  -- Connect to the node.
  let connectInfo :: LocalNodeConnectInfo
connectInfo =
        LocalNodeConnectInfo
          { localConsensusModeParams :: ConsensusModeParams
localConsensusModeParams = ConsensusModeParams
cardanoModeParams
          , localNodeNetworkId :: NetworkId
localNodeNetworkId = NetworkId
networkId'
          , localNodeSocketPath :: SocketPath
localNodeSocketPath = SocketPath
socketPath
          }

  (IOException -> FoldBlocksError)
-> ExceptT IOException IO () -> ExceptT FoldBlocksError IO ()
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError IOException -> FoldBlocksError
FoldBlocksIOException (ExceptT IOException IO () -> ExceptT FoldBlocksError IO ())
-> ExceptT IOException IO () -> ExceptT FoldBlocksError IO ()
forall a b. (a -> b) -> a -> b
$
    IO () -> ExceptT IOException IO ()
forall a. IO a -> ExceptT IOException IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT IOException IO ())
-> IO () -> ExceptT IOException IO ()
forall a b. (a -> b) -> a -> b
$
      LocalNodeConnectInfo -> LocalNodeClientProtocolsInMode -> IO ()
forall (m :: * -> *).
MonadIO m =>
LocalNodeConnectInfo -> LocalNodeClientProtocolsInMode -> m ()
connectToLocalNode
        LocalNodeConnectInfo
connectInfo
        (MVar (ConditionResult, s)
-> IORef (Maybe LedgerStateError)
-> Env
-> LedgerState
-> LocalNodeClientProtocolsInMode
protocols MVar (ConditionResult, s)
stateMv IORef (Maybe LedgerStateError)
errorIORef Env
env LedgerState
ledgerState)

  IO (Maybe LedgerStateError)
-> ExceptT FoldBlocksError IO (Maybe LedgerStateError)
forall a. IO a -> ExceptT FoldBlocksError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe LedgerStateError) -> IO (Maybe LedgerStateError)
forall a. IORef a -> IO a
readIORef IORef (Maybe LedgerStateError)
errorIORef) ExceptT FoldBlocksError IO (Maybe LedgerStateError)
-> (Maybe LedgerStateError
    -> ExceptT FoldBlocksError IO (ConditionResult, s))
-> ExceptT FoldBlocksError IO (ConditionResult, s)
forall a b.
ExceptT FoldBlocksError IO a
-> (a -> ExceptT FoldBlocksError IO b)
-> ExceptT FoldBlocksError IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just LedgerStateError
err -> FoldBlocksError -> ExceptT FoldBlocksError IO (ConditionResult, s)
forall a. FoldBlocksError -> ExceptT FoldBlocksError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FoldBlocksError
 -> ExceptT FoldBlocksError IO (ConditionResult, s))
-> FoldBlocksError
-> ExceptT FoldBlocksError IO (ConditionResult, s)
forall a b. (a -> b) -> a -> b
$ LedgerStateError -> FoldBlocksError
FoldBlocksApplyBlockError LedgerStateError
err
    Maybe LedgerStateError
Nothing -> (IOException -> FoldBlocksError)
-> ExceptT IOException IO (ConditionResult, s)
-> ExceptT FoldBlocksError IO (ConditionResult, s)
forall e' (t :: (* -> *) -> * -> *) (m :: * -> *) e a.
MonadTransError e' t m =>
(e -> e') -> ExceptT e m a -> t m a
modifyError IOException -> FoldBlocksError
FoldBlocksIOException (ExceptT IOException IO (ConditionResult, s)
 -> ExceptT FoldBlocksError IO (ConditionResult, s))
-> (IO (ConditionResult, s)
    -> ExceptT IOException IO (ConditionResult, s))
-> IO (ConditionResult, s)
-> ExceptT FoldBlocksError IO (ConditionResult, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (ConditionResult, s)
-> ExceptT IOException IO (ConditionResult, s)
forall a. IO a -> ExceptT IOException IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ConditionResult, s)
 -> ExceptT FoldBlocksError IO (ConditionResult, s))
-> IO (ConditionResult, s)
-> ExceptT FoldBlocksError IO (ConditionResult, s)
forall a b. (a -> b) -> a -> b
$ MVar (ConditionResult, s) -> IO (ConditionResult, s)
forall a. MVar a -> IO a
readMVar MVar (ConditionResult, s)
stateMv
 where
  protocols
    :: ()
    => MVar (ConditionResult, s)
    -> IORef (Maybe LedgerStateError)
    -> Env
    -> LedgerState
    -> LocalNodeClientProtocolsInMode
  protocols :: MVar (ConditionResult, s)
-> IORef (Maybe LedgerStateError)
-> Env
-> LedgerState
-> LocalNodeClientProtocolsInMode
protocols MVar (ConditionResult, s)
stateMv IORef (Maybe LedgerStateError)
errorIORef Env
env LedgerState
ledgerState =
    LocalNodeClientProtocols
      { localChainSyncClient :: LocalChainSyncClient BlockInMode ChainPoint ChainTip IO
localChainSyncClient =
          ChainSyncClientPipelined BlockInMode ChainPoint ChainTip IO ()
-> LocalChainSyncClient BlockInMode ChainPoint ChainTip IO
forall block point tip (m :: * -> *).
ChainSyncClientPipelined block point tip m ()
-> LocalChainSyncClient block point tip m
LocalChainSyncClientPipelined (Word16
-> MVar (ConditionResult, s)
-> IORef (Maybe LedgerStateError)
-> Env
-> LedgerState
-> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip IO ()
chainSyncClient Word16
50 MVar (ConditionResult, s)
stateMv IORef (Maybe LedgerStateError)
errorIORef Env
env LedgerState
ledgerState)
      , localTxSubmissionClient :: Maybe
  (LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode IO ())
localTxSubmissionClient = Maybe
  (LocalTxSubmissionClient
     TxInMode TxValidationErrorInCardanoMode IO ())
forall a. Maybe a
Nothing
      , localStateQueryClient :: Maybe
  (LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ())
localStateQueryClient = Maybe
  (LocalStateQueryClient BlockInMode ChainPoint QueryInMode IO ())
forall a. Maybe a
Nothing
      , localTxMonitoringClient :: Maybe (LocalTxMonitorClient TxIdInMode TxInMode SlotNo IO ())
localTxMonitoringClient = Maybe (LocalTxMonitorClient TxIdInMode TxInMode SlotNo IO ())
forall a. Maybe a
Nothing
      }

  -- \| Defines the client side of the chain sync protocol.
  chainSyncClient
    :: Word16
    -- \^ The maximum number of concurrent requests.
    -> MVar (ConditionResult, s)
    -- \^ State accumulator. Written to on every block.
    -> IORef (Maybe LedgerStateError)
    -- \^ Resulting error if any. Written to once on protocol
    -- completion.
    -> Env
    -> LedgerState
    -> CSP.ChainSyncClientPipelined
        BlockInMode
        ChainPoint
        ChainTip
        IO
        ()
  -- \^ Client returns maybe an error.
  chainSyncClient :: Word16
-> MVar (ConditionResult, s)
-> IORef (Maybe LedgerStateError)
-> Env
-> LedgerState
-> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip IO ()
chainSyncClient Word16
pipelineSize MVar (ConditionResult, s)
stateMv IORef (Maybe LedgerStateError)
errorIORef' Env
env LedgerState
ledgerState0 =
    IO (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ())
-> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip IO ()
forall header point tip (m :: * -> *) a.
m (ClientPipelinedStIdle 'Z header point tip m a)
-> ChainSyncClientPipelined header point tip m a
CSP.ChainSyncClientPipelined (IO
   (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ())
 -> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip IO ())
-> IO
     (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ())
-> ChainSyncClientPipelined BlockInMode ChainPoint ChainTip IO ()
forall a b. (a -> b) -> a -> b
$
      ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ()
 -> IO
      (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ()))
-> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ())
forall a b. (a -> b) -> a -> b
$
        WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat 'Z
-> History LedgerStateEvents
-> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History LedgerStateEvents
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
forall t. WithOrigin t
Origin WithOrigin BlockNo
forall t. WithOrigin t
Origin Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero History LedgerStateEvents
initialLedgerStateHistory
   where
    initialLedgerStateHistory :: History LedgerStateEvents
initialLedgerStateHistory = (SlotNo, LedgerStateEvents, WithOrigin BlockInMode)
-> History LedgerStateEvents
forall a. a -> Seq a
Seq.singleton (SlotNo
0, (LedgerState
ledgerState0, []), WithOrigin BlockInMode
forall t. WithOrigin t
Origin)

    clientIdle_RequestMoreN
      :: WithOrigin BlockNo
      -> WithOrigin BlockNo
      -> Nat n -- Number of requests inflight.
      -> LedgerStateHistory
      -> CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
    clientIdle_RequestMoreN :: forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History LedgerStateEvents
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
clientTip WithOrigin BlockNo
serverTip Nat n
n History LedgerStateEvents
knownLedgerStates =
      case Word16
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> PipelineDecision n
forall (n :: N).
Word16
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> PipelineDecision n
pipelineDecisionMax Word16
pipelineSize Nat n
n WithOrigin BlockNo
clientTip WithOrigin BlockNo
serverTip of
        PipelineDecision n
Collect -> case Nat n
n of
          Succ Nat n
predN -> Maybe
  (IO
     (ClientPipelinedStIdle
        ('S n) BlockInMode ChainPoint ChainTip IO ()))
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
-> ClientPipelinedStIdle
     ('S n) BlockInMode ChainPoint ChainTip IO ()
forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CSP.CollectResponse Maybe
  (IO
     (ClientPipelinedStIdle
        ('S n) BlockInMode ChainPoint ChainTip IO ()))
forall a. Maybe a
Nothing (Nat n
-> History LedgerStateEvents
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
forall (n :: N).
Nat n
-> History LedgerStateEvents
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
clientNextN Nat n
predN History LedgerStateEvents
knownLedgerStates)
        PipelineDecision n
_ ->
          IO ()
-> ClientPipelinedStIdle
     ('S n) BlockInMode ChainPoint ChainTip IO ()
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
forall (m :: * -> *) (n :: N) header point tip a.
m ()
-> ClientPipelinedStIdle ('S n) header point tip m a
-> ClientPipelinedStIdle n header point tip m a
CSP.SendMsgRequestNextPipelined
            (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
            (WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat ('S n)
-> History LedgerStateEvents
-> ClientPipelinedStIdle
     ('S n) BlockInMode ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History LedgerStateEvents
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
clientTip WithOrigin BlockNo
serverTip (Nat n -> Nat ('S n)
forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat n
n) History LedgerStateEvents
knownLedgerStates)

    clientNextN
      :: Nat n -- Number of requests inflight.
      -> LedgerStateHistory
      -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO ()
    clientNextN :: forall (n :: N).
Nat n
-> History LedgerStateEvents
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
clientNextN Nat n
n History LedgerStateEvents
knownLedgerStates =
      CSP.ClientStNext
        { recvMsgRollForward :: BlockInMode
-> ChainTip
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
CSP.recvMsgRollForward = \blockInMode :: BlockInMode
blockInMode@(BlockInMode CardanoEra era
era (Block (BlockHeader SlotNo
slotNo Hash BlockHeader
_ BlockNo
currBlockNo) [Tx era]
_)) ChainTip
serverChainTip -> do
            let newLedgerStateE :: Either LedgerStateError LedgerStateEvents
newLedgerStateE =
                  Env
-> LedgerState
-> ValidationMode
-> BlockInMode
-> Either LedgerStateError LedgerStateEvents
applyBlock
                    Env
env
                    ( LedgerState
-> ((SlotNo, LedgerStateEvents, WithOrigin BlockInMode)
    -> LedgerState)
-> Maybe (SlotNo, LedgerStateEvents, WithOrigin BlockInMode)
-> LedgerState
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                        (String -> LedgerState
forall a. HasCallStack => String -> a
error String
"Impossible! Missing Ledger state")
                        (\(SlotNo
_, (LedgerState
ledgerState, [LedgerEvent]
_), WithOrigin BlockInMode
_) -> LedgerState
ledgerState)
                        (Int
-> History LedgerStateEvents
-> Maybe (SlotNo, LedgerStateEvents, WithOrigin BlockInMode)
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
0 History LedgerStateEvents
knownLedgerStates)
                    )
                    ValidationMode
validationMode
                    BlockInMode
blockInMode
            case CardanoEra era -> Maybe (ShelleyBasedEra era)
forall (eon :: * -> *) era.
Eon eon =>
CardanoEra era -> Maybe (eon era)
forEraMaybeEon CardanoEra era
era of
              Maybe (ShelleyBasedEra era)
Nothing ->
                let !err :: Maybe LedgerStateError
err = LedgerStateError -> Maybe LedgerStateError
forall a. a -> Maybe a
Just LedgerStateError
ByronEraUnsupported
                 in Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
clientIdle_DoneNwithMaybeError Nat n
n Maybe LedgerStateError
err
              Just ShelleyBasedEra era
sbe ->
                case Either LedgerStateError LedgerStateEvents
newLedgerStateE of
                  Left LedgerStateError
err -> Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
clientIdle_DoneNwithMaybeError Nat n
n (LedgerStateError -> Maybe LedgerStateError
forall a. a -> Maybe a
Just LedgerStateError
err)
                  Right new :: LedgerStateEvents
new@(LedgerState
newLedgerState, [LedgerEvent]
ledgerEvents) -> do
                    let (History LedgerStateEvents
knownLedgerStates', History LedgerStateEvents
_) = Env
-> History LedgerStateEvents
-> SlotNo
-> LedgerStateEvents
-> BlockInMode
-> (History LedgerStateEvents, History LedgerStateEvents)
forall a.
Env
-> History a
-> SlotNo
-> a
-> BlockInMode
-> (History a, History a)
pushLedgerState Env
env History LedgerStateEvents
knownLedgerStates SlotNo
slotNo LedgerStateEvents
new BlockInMode
blockInMode
                        newClientTip :: WithOrigin BlockNo
newClientTip = BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At BlockNo
currBlockNo
                        newServerTip :: WithOrigin BlockNo
newServerTip = ChainTip -> WithOrigin BlockNo
fromChainTip ChainTip
serverChainTip
                    case ShelleyBasedEra era
-> CardanoLedgerState StandardCrypto
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall era.
ShelleyBasedEra era
-> CardanoLedgerState StandardCrypto
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
getNewEpochState ShelleyBasedEra era
sbe (CardanoLedgerState StandardCrypto
 -> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era)))
-> CardanoLedgerState StandardCrypto
-> Either LedgerStateError (NewEpochState (ShelleyLedgerEra era))
forall a b. (a -> b) -> a -> b
$ LedgerState -> CardanoLedgerState StandardCrypto
clsState LedgerState
newLedgerState of
                      Left LedgerStateError
e ->
                        let !err :: Maybe LedgerStateError
err = LedgerStateError -> Maybe LedgerStateError
forall a. a -> Maybe a
Just LedgerStateError
e
                         in Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
clientIdle_DoneNwithMaybeError Nat n
n Maybe LedgerStateError
err
                      Right NewEpochState (ShelleyLedgerEra era)
lState -> do
                        let newEpochState :: AnyNewEpochState
newEpochState = ShelleyBasedEra era
-> NewEpochState (ShelleyLedgerEra era) -> AnyNewEpochState
forall era.
ShelleyBasedEra era
-> NewEpochState (ShelleyLedgerEra era) -> AnyNewEpochState
AnyNewEpochState ShelleyBasedEra era
sbe NewEpochState (ShelleyLedgerEra era)
lState
                        -- Run the condition function in an exclusive lock.
                        -- There can be only one place where `takeMVar stateMv` exists otherwise this
                        -- code will deadlock!
                        ConditionResult
condition <- IO (ConditionResult, s)
-> ((ConditionResult, s) -> IO Bool)
-> ((ConditionResult, s) -> IO ConditionResult)
-> IO ConditionResult
forall (m :: * -> *) a b c.
(HasCallStack, MonadMask m) =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (MVar (ConditionResult, s) -> IO (ConditionResult, s)
forall a. MVar a -> IO a
takeMVar MVar (ConditionResult, s)
stateMv) (MVar (ConditionResult, s) -> (ConditionResult, s) -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar (ConditionResult, s)
stateMv) (((ConditionResult, s) -> IO ConditionResult)
 -> IO ConditionResult)
-> ((ConditionResult, s) -> IO ConditionResult)
-> IO ConditionResult
forall a b. (a -> b) -> a -> b
$ \(ConditionResult
_prevCondition, s
previousState) -> do
                          updatedState :: (ConditionResult, s)
updatedState@(!ConditionResult
newCondition, !s
_) <-
                            StateT s IO ConditionResult -> s -> IO (ConditionResult, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (AnyNewEpochState
-> SlotNo -> BlockNo -> StateT s IO ConditionResult
checkCondition AnyNewEpochState
newEpochState SlotNo
slotNo BlockNo
currBlockNo) s
previousState
                          MVar (ConditionResult, s) -> (ConditionResult, s) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (ConditionResult, s)
stateMv (ConditionResult, s)
updatedState
                          ConditionResult -> IO ConditionResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConditionResult
newCondition
                        -- Have we reached the termination epoch?
                        case EpochNo -> [LedgerEvent] -> Maybe EpochNo
atTerminationEpoch EpochNo
terminationEpoch [LedgerEvent]
ledgerEvents of
                          Just !EpochNo
currentEpoch -> do
                            -- confirmed this works: error $ "atTerminationEpoch: Terminated at: " <> show currentEpoch
                            let !err :: Maybe LedgerStateError
err = LedgerStateError -> Maybe LedgerStateError
forall a. a -> Maybe a
Just (LedgerStateError -> Maybe LedgerStateError)
-> LedgerStateError -> Maybe LedgerStateError
forall a b. (a -> b) -> a -> b
$ EpochNo -> LedgerStateError
TerminationEpochReached EpochNo
currentEpoch
                            Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
clientIdle_DoneNwithMaybeError Nat n
n Maybe LedgerStateError
err
                          Maybe EpochNo
Nothing -> do
                            case ConditionResult
condition of
                              ConditionResult
ConditionMet ->
                                let !noError :: Maybe a
noError = Maybe a
forall a. Maybe a
Nothing
                                 in Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
clientIdle_DoneNwithMaybeError Nat n
n Maybe LedgerStateError
forall a. Maybe a
noError
                              ConditionResult
ConditionNotMet -> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
 -> IO
      (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()))
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall a b. (a -> b) -> a -> b
$ WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History LedgerStateEvents
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History LedgerStateEvents
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
newClientTip WithOrigin BlockNo
newServerTip Nat n
n History LedgerStateEvents
knownLedgerStates'
        , recvMsgRollBackward :: ChainPoint
-> ChainTip
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
CSP.recvMsgRollBackward = \ChainPoint
chainPoint ChainTip
serverChainTip -> do
            let newClientTip :: WithOrigin t
newClientTip = WithOrigin t
forall t. WithOrigin t
Origin -- We don't actually keep track of blocks so we temporarily "forget" the tip.
                newServerTip :: WithOrigin BlockNo
newServerTip = ChainTip -> WithOrigin BlockNo
fromChainTip ChainTip
serverChainTip
                truncatedKnownLedgerStates :: History LedgerStateEvents
truncatedKnownLedgerStates = case ChainPoint
chainPoint of
                  ChainPoint
ChainPointAtGenesis -> History LedgerStateEvents
initialLedgerStateHistory
                  ChainPoint SlotNo
slotNo Hash BlockHeader
_ -> History LedgerStateEvents -> SlotNo -> History LedgerStateEvents
forall a. History a -> SlotNo -> History a
rollBackLedgerStateHist History LedgerStateEvents
knownLedgerStates SlotNo
slotNo
            ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History LedgerStateEvents
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> History LedgerStateEvents
-> ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
forall t. WithOrigin t
newClientTip WithOrigin BlockNo
newServerTip Nat n
n History LedgerStateEvents
truncatedKnownLedgerStates)
        }

    clientIdle_DoneNwithMaybeError
      :: Nat n -- Number of requests inflight.
      -> Maybe LedgerStateError -- Return value (maybe an error)
      -> IO (CSP.ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
    clientIdle_DoneNwithMaybeError :: forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
clientIdle_DoneNwithMaybeError Nat n
n Maybe LedgerStateError
errorMay = case Nat n
n of
      Succ Nat n
predN -> do
        ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
  (IO
     (ClientPipelinedStIdle
        ('S n) BlockInMode ChainPoint ChainTip IO ()))
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
-> ClientPipelinedStIdle
     ('S n) BlockInMode ChainPoint ChainTip IO ()
forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CSP.CollectResponse Maybe
  (IO
     (ClientPipelinedStIdle
        ('S n) BlockInMode ChainPoint ChainTip IO ()))
forall a. Maybe a
Nothing (Nat n
-> Maybe LedgerStateError
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
clientNext_DoneNwithMaybeError Nat n
predN Maybe LedgerStateError
errorMay)) -- Ignore remaining message responses
      Nat n
Zero -> do
        IORef (Maybe LedgerStateError)
-> (Maybe LedgerStateError -> (Maybe LedgerStateError, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Maybe LedgerStateError)
errorIORef' ((Maybe LedgerStateError -> (Maybe LedgerStateError, ())) -> IO ())
-> ((Maybe LedgerStateError, ())
    -> Maybe LedgerStateError -> (Maybe LedgerStateError, ()))
-> (Maybe LedgerStateError, ())
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe LedgerStateError, ())
-> Maybe LedgerStateError -> (Maybe LedgerStateError, ())
forall a b. a -> b -> a
const ((Maybe LedgerStateError, ()) -> IO ())
-> (Maybe LedgerStateError, ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Maybe LedgerStateError
errorMay, ())
        ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (()
-> ClientPipelinedStIdle 'Z BlockInMode ChainPoint ChainTip IO ()
forall a header point tip (m :: * -> *).
a -> ClientPipelinedStIdle 'Z header point tip m a
CSP.SendMsgDone ())

    clientNext_DoneNwithMaybeError
      :: Nat n -- Number of requests inflight.
      -> Maybe LedgerStateError -- Return value (maybe an error)
      -> CSP.ClientStNext n BlockInMode ChainPoint ChainTip IO ()
    clientNext_DoneNwithMaybeError :: forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> ClientStNext n BlockInMode ChainPoint ChainTip IO ()
clientNext_DoneNwithMaybeError Nat n
n Maybe LedgerStateError
errorMay =
      CSP.ClientStNext
        { recvMsgRollForward :: BlockInMode
-> ChainTip
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
CSP.recvMsgRollForward = \BlockInMode
_ ChainTip
_ -> Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
clientIdle_DoneNwithMaybeError Nat n
n Maybe LedgerStateError
errorMay
        , recvMsgRollBackward :: ChainPoint
-> ChainTip
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
CSP.recvMsgRollBackward = \ChainPoint
_ ChainTip
_ -> Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle n BlockInMode ChainPoint ChainTip IO ())
clientIdle_DoneNwithMaybeError Nat n
n Maybe LedgerStateError
errorMay
        }

    fromChainTip :: ChainTip -> WithOrigin BlockNo
    fromChainTip :: ChainTip -> WithOrigin BlockNo
fromChainTip ChainTip
ct = case ChainTip
ct of
      ChainTip
ChainTipAtGenesis -> WithOrigin BlockNo
forall t. WithOrigin t
Origin
      ChainTip SlotNo
_ Hash BlockHeader
_ BlockNo
bno -> BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At BlockNo
bno

atTerminationEpoch :: EpochNo -> [LedgerEvent] -> Maybe EpochNo
atTerminationEpoch :: EpochNo -> [LedgerEvent] -> Maybe EpochNo
atTerminationEpoch EpochNo
terminationEpoch [LedgerEvent]
events =
  [EpochNo] -> Maybe EpochNo
forall a. [a] -> Maybe a
listToMaybe
    [ EpochNo
currentEpoch'
    | PoolReap PoolReapDetails
poolReapDets <- [LedgerEvent]
events
    , let currentEpoch' :: EpochNo
currentEpoch' = PoolReapDetails -> EpochNo
prdEpochNo PoolReapDetails
poolReapDets
    , EpochNo
currentEpoch' EpochNo -> EpochNo -> Bool
forall a. Ord a => a -> a -> Bool
>= EpochNo
terminationEpoch
    ]

handleExceptions
  :: MonadIOTransError FoldBlocksError t m
  => ExceptT FoldBlocksError IO a
  -> t m a
handleExceptions :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadIOTransError FoldBlocksError t m =>
ExceptT FoldBlocksError IO a -> t m a
handleExceptions = Either FoldBlocksError a -> t m a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either FoldBlocksError a -> t m a)
-> (ExceptT FoldBlocksError IO a -> t m (Either FoldBlocksError a))
-> ExceptT FoldBlocksError IO a
-> t m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either FoldBlocksError a) -> t m (Either FoldBlocksError a)
forall a. IO a -> t m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either FoldBlocksError a) -> t m (Either FoldBlocksError a))
-> (ExceptT FoldBlocksError IO a -> IO (Either FoldBlocksError a))
-> ExceptT FoldBlocksError IO a
-> t m (Either FoldBlocksError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT FoldBlocksError IO a -> IO (Either FoldBlocksError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT FoldBlocksError IO a -> IO (Either FoldBlocksError a))
-> (ExceptT FoldBlocksError IO a -> ExceptT FoldBlocksError IO a)
-> ExceptT FoldBlocksError IO a
-> IO (Either FoldBlocksError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExceptT FoldBlocksError IO a
 -> [Handler (ExceptT FoldBlocksError IO) a]
 -> ExceptT FoldBlocksError IO a)
-> [Handler (ExceptT FoldBlocksError IO) a]
-> ExceptT FoldBlocksError IO a
-> ExceptT FoldBlocksError IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExceptT FoldBlocksError IO a
-> [Handler (ExceptT FoldBlocksError IO) a]
-> ExceptT FoldBlocksError IO a
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
catches [Handler (ExceptT FoldBlocksError IO) a]
forall {a}. [Handler (ExceptT FoldBlocksError IO) a]
handlers
 where
  handlers :: [Handler (ExceptT FoldBlocksError IO) a]
handlers =
    [ (IOException -> ExceptT FoldBlocksError IO a)
-> Handler (ExceptT FoldBlocksError IO) a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((IOException -> ExceptT FoldBlocksError IO a)
 -> Handler (ExceptT FoldBlocksError IO) a)
-> (IOException -> ExceptT FoldBlocksError IO a)
-> Handler (ExceptT FoldBlocksError IO) a
forall a b. (a -> b) -> a -> b
$ FoldBlocksError -> ExceptT FoldBlocksError IO a
forall a. FoldBlocksError -> ExceptT FoldBlocksError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FoldBlocksError -> ExceptT FoldBlocksError IO a)
-> (IOException -> FoldBlocksError)
-> IOException
-> ExceptT FoldBlocksError IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> FoldBlocksError
FoldBlocksIOException
    , (MuxError -> ExceptT FoldBlocksError IO a)
-> Handler (ExceptT FoldBlocksError IO) a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((MuxError -> ExceptT FoldBlocksError IO a)
 -> Handler (ExceptT FoldBlocksError IO) a)
-> (MuxError -> ExceptT FoldBlocksError IO a)
-> Handler (ExceptT FoldBlocksError IO) a
forall a b. (a -> b) -> a -> b
$ FoldBlocksError -> ExceptT FoldBlocksError IO a
forall a. FoldBlocksError -> ExceptT FoldBlocksError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FoldBlocksError -> ExceptT FoldBlocksError IO a)
-> (MuxError -> FoldBlocksError)
-> MuxError
-> ExceptT FoldBlocksError IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MuxError -> FoldBlocksError
FoldBlocksMuxError
    ]

-- WARNING: Do NOT use this function anywhere else except in its current call sites.
-- This is a temporary work around.
fromConsensusPoolDistr :: Consensus.PoolDistr c -> SL.PoolDistr c
fromConsensusPoolDistr :: forall c. PoolDistr c -> PoolDistr c
fromConsensusPoolDistr PoolDistr c
cpd =
  SL.PoolDistr
    { unPoolDistr :: Map (KeyHash 'StakePool c) (IndividualPoolStake c)
SL.unPoolDistr = (IndividualPoolStake c -> IndividualPoolStake c)
-> Map (KeyHash 'StakePool c) (IndividualPoolStake c)
-> Map (KeyHash 'StakePool c) (IndividualPoolStake c)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map IndividualPoolStake c -> IndividualPoolStake c
forall c. IndividualPoolStake c -> IndividualPoolStake c
toLedgerIndividualPoolStake (Map (KeyHash 'StakePool c) (IndividualPoolStake c)
 -> Map (KeyHash 'StakePool c) (IndividualPoolStake c))
-> Map (KeyHash 'StakePool c) (IndividualPoolStake c)
-> Map (KeyHash 'StakePool c) (IndividualPoolStake c)
forall a b. (a -> b) -> a -> b
$ PoolDistr c -> Map (KeyHash 'StakePool c) (IndividualPoolStake c)
forall c.
PoolDistr c -> Map (KeyHash 'StakePool c) (IndividualPoolStake c)
Consensus.unPoolDistr PoolDistr c
cpd
    , pdTotalActiveStake :: CompactForm Coin
SL.pdTotalActiveStake = Word64 -> CompactForm Coin
SL.CompactCoin Word64
0
    }

-- WARNING: Do NOT use this function anywhere else except in its current call sites.
-- This is a temporary work around.
toLedgerIndividualPoolStake :: Consensus.IndividualPoolStake c -> SL.IndividualPoolStake c
toLedgerIndividualPoolStake :: forall c. IndividualPoolStake c -> IndividualPoolStake c
toLedgerIndividualPoolStake IndividualPoolStake c
ips =
  SL.IndividualPoolStake
    { individualPoolStake :: Rational
SL.individualPoolStake = IndividualPoolStake c -> Rational
forall c. IndividualPoolStake c -> Rational
Consensus.individualPoolStake IndividualPoolStake c
ips
    , individualPoolStakeVrf :: Hash c (VerKeyVRF c)
SL.individualPoolStakeVrf = IndividualPoolStake c -> Hash c (VerKeyVRF c)
forall c. IndividualPoolStake c -> Hash c (VerKeyVRF c)
Consensus.individualPoolStakeVrf IndividualPoolStake c
ips
    , individualTotalPoolStake :: CompactForm Coin
SL.individualTotalPoolStake = Word64 -> CompactForm Coin
SL.CompactCoin Word64
0
    }