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

module Cardano.Api.LedgerState
  ( -- * Initialization / Accumulation
    Env(..)
  , envSecurityParam
  , LedgerState
      ( ..
      , LedgerStateByron
      , LedgerStateShelley
      , LedgerStateAllegra
      , LedgerStateMary
      , LedgerStateAlonzo
      )
  , initialLedgerState
  , applyBlock
  , ValidationMode(..)
  , applyBlockWithEvents

    -- * Traversing the block chain
  , foldBlocks
  , chainSyncClientWithLedgerState
  , chainSyncClientPipelinedWithLedgerState

   -- * Errors
  , LedgerStateError(..)
  , FoldBlocksError(..)
  , GenesisConfigError(..)
  , InitialLedgerStateError(..)
  , renderLedgerStateError
  , renderFoldBlocksError
  , renderGenesisConfigError
  , renderInitialLedgerStateError

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

import           Prelude

import           Control.Exception
import           Control.Monad (when)
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, left)
import           Control.State.Transition
import           Data.Aeson as Aeson
import qualified Data.Aeson.Types as Data.Aeson.Types.Internal
import           Data.Bifunctor
import           Data.ByteArray (ByteArrayAccess)
import qualified Data.ByteArray
import           Data.ByteString as BS
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Lazy as LB
import           Data.ByteString.Short as BSS
import           Data.Foldable
import           Data.IORef
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (mapMaybe)
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.Sharing (FromSharedCBOR, Interns, Share)
import           Data.SOP.Strict (NP (..))
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import           Data.Text.Lazy (toStrict)
import           Data.Text.Lazy.Builder (toLazyText)
import           Data.Word
import qualified Data.Yaml as Yaml
import           Formatting.Buildable (build)
import           GHC.Records (HasField (..))
import           Network.TypedProtocol.Pipelined (Nat (..))
import           System.FilePath

import           Cardano.Api.Block
import           Cardano.Api.Certificate
import           Cardano.Api.Eras
import           Cardano.Api.Error
import           Cardano.Api.IPC (ConsensusModeParams (..),
                   LocalChainSyncClient (LocalChainSyncClientPipelined),
                   LocalNodeClientProtocols (..), LocalNodeClientProtocolsInMode,
                   LocalNodeConnectInfo (..), connectToLocalNode)
import           Cardano.Api.KeysPraos
import           Cardano.Api.LedgerEvent (LedgerEvent, toLedgerEvent)
import           Cardano.Api.Modes (CardanoMode, EpochSlots (..))
import qualified Cardano.Api.Modes as Api
import           Cardano.Api.NetworkId (NetworkId (..), NetworkMagic (NetworkMagic))
import           Cardano.Api.ProtocolParameters
import           Cardano.Api.Query (CurrentEpochState (..), ProtocolState,
                   SerialisedCurrentEpochState (..), decodeCurrentEpochState, decodeProtocolState)
import           Cardano.Api.Utils (textShow)
import           Cardano.Binary (DecoderError, FromCBOR)
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           Cardano.Ledger.BaseTypes (Globals (..), Nonce, UnitInterval, (⭒))
import qualified Cardano.Ledger.BaseTypes as Shelley.Spec
import qualified Cardano.Ledger.BHeaderView as Ledger
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Credential as Shelley.Spec
import qualified Cardano.Ledger.Era
import qualified Cardano.Ledger.Era as Ledger
import qualified Cardano.Ledger.Keys as Shelley.Spec
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.Genesis as Shelley.Spec
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 qualified Ouroboros.Consensus.Byron.Ledger.Block 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           Ouroboros.Consensus.Ledger.Basics (LedgerResult (lrEvents), lrResult)
import qualified Ouroboros.Consensus.Ledger.Extended as Ledger
import qualified Ouroboros.Consensus.Mempool.TxLimits as TxLimits
import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus
import           Ouroboros.Consensus.Protocol.Abstract (ChainDepState, ConsensusProtocol (..))
import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus
import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus
import           Ouroboros.Consensus.Protocol.Praos.VRF (mkInputVRF, vrfLeaderValue)
import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos
import qualified Ouroboros.Consensus.Shelley.Eras as Shelley
import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Shelley
import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Shelley
import           Ouroboros.Consensus.Shelley.Node (ShelleyGenesis (..))
import qualified Ouroboros.Consensus.Shelley.Node.Praos as Consensus
import           Ouroboros.Consensus.TypeFamilyWrappers (WrapLedgerEvent (WrapLedgerEvent))
import qualified Ouroboros.Network.Block
import qualified Ouroboros.Network.Protocol.ChainSync.Client as CS
import qualified Ouroboros.Network.Protocol.ChainSync.ClientPipelined as CSP
import           Ouroboros.Network.Protocol.ChainSync.PipelineDecision

data InitialLedgerStateError
  = ILSEConfigFile Text
  -- ^ Failed to read or parse the network config file.
  | ILSEGenesisFile GenesisConfigError
  -- ^ Failed to read or parse a genesis file linked from the network config file.
  | ILSELedgerConsensusConfig GenesisConfigError
  -- ^ Failed to derive the Ledger or Consensus config.

renderInitialLedgerStateError :: InitialLedgerStateError -> Text
renderInitialLedgerStateError :: InitialLedgerStateError -> Text
renderInitialLedgerStateError InitialLedgerStateError
ilse = case InitialLedgerStateError
ilse of
  ILSEConfigFile Text
err ->
    Text
"Failed to read or parse the network config file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
  ILSEGenesisFile GenesisConfigError
err ->
    Text
"Failed to read or parse a genesis file linked from the network config file: "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GenesisConfigError -> Text
renderGenesisConfigError GenesisConfigError
err
  ILSELedgerConsensusConfig GenesisConfigError
err ->
    Text
"Failed to derive the Ledger or Consensus config: "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GenesisConfigError -> Text
renderGenesisConfigError GenesisConfigError
err

data LedgerStateError
  = ApplyBlockHashMismatch Text
  -- ^ When using QuickValidation, the block hash did not match the expected
  -- block hash after applying a new block to the current ledger state.
  | ApplyBlockError (Consensus.HardForkLedgerError (Consensus.CardanoEras Consensus.StandardCrypto))
  -- ^ When using FullValidation, an error occurred when applying a new block
  -- to the current ledger state.
  | InvalidRollback
  -- ^ Encountered a rollback larger than the security parameter.
      SlotNo     -- ^ Oldest known slot number that we can roll back to.
      ChainPoint -- ^ Rollback was attempted to this point.
  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
showList :: [LedgerStateError] -> ShowS
$cshowList :: [LedgerStateError] -> ShowS
show :: LedgerStateError -> String
$cshow :: LedgerStateError -> String
showsPrec :: Int -> LedgerStateError -> ShowS
$cshowsPrec :: Int -> LedgerStateError -> ShowS
Show)

renderLedgerStateError :: LedgerStateError -> Text
renderLedgerStateError :: LedgerStateError -> Text
renderLedgerStateError = \case
  ApplyBlockHashMismatch Text
err -> Text
"Applying a block did not result in the expected block hash: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
  ApplyBlockError HardForkLedgerError (CardanoEras StandardCrypto)
hardForkLedgerError -> Text
"Applying a block resulted in an error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HardForkLedgerError (CardanoEras StandardCrypto) -> Text
forall a. Show a => a -> Text
textShow HardForkLedgerError (CardanoEras StandardCrypto)
hardForkLedgerError
  InvalidRollback SlotNo
oldestSupported ChainPoint
rollbackPoint ->
      Text
"Encountered a rollback larger than the security parameter. Attempted to roll back to "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ChainPoint -> Text
forall a. Show a => a -> Text
textShow ChainPoint
rollbackPoint
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", but oldest supported slot is "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SlotNo -> Text
forall a. Show a => a -> Text
textShow SlotNo
oldestSupported

-- | Get the environment and initial ledger state.
initialLedgerState
  :: FilePath
  -- ^ Path to the cardano-node config file (e.g. <path to cardano-node project>/configuration/cardano/mainnet-config.json)
  ->  ExceptT InitialLedgerStateError IO (Env, LedgerState)
  -- ^ The environment and initial ledger state
initialLedgerState :: String -> ExceptT InitialLedgerStateError IO (Env, LedgerState)
initialLedgerState String
networkConfigFile = do
  -- TODO Once support for querying the ledger config is added to the node, we
  -- can remove the networkConfigFile argument and much of the code in this
  -- module.
  NodeConfig
config <- (Text -> InitialLedgerStateError)
-> ExceptT Text IO NodeConfig
-> ExceptT InitialLedgerStateError IO NodeConfig
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Text -> InitialLedgerStateError
ILSEConfigFile
                  (NetworkConfigFile -> ExceptT Text IO NodeConfig
readNetworkConfig (String -> NetworkConfigFile
NetworkConfigFile String
networkConfigFile))
  GenesisConfig
genesisConfig <- (GenesisConfigError -> InitialLedgerStateError)
-> ExceptT GenesisConfigError IO GenesisConfig
-> ExceptT InitialLedgerStateError IO GenesisConfig
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT GenesisConfigError -> InitialLedgerStateError
ILSEGenesisFile (NodeConfig -> ExceptT GenesisConfigError IO GenesisConfig
readCardanoGenesisConfig NodeConfig
config)
  Env
env <- (GenesisConfigError -> InitialLedgerStateError)
-> ExceptT GenesisConfigError IO Env
-> ExceptT InitialLedgerStateError IO Env
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT GenesisConfigError -> InitialLedgerStateError
ILSELedgerConsensusConfig (Either GenesisConfigError Env -> ExceptT GenesisConfigError IO 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)
-> ExceptT InitialLedgerStateError IO (Env, LedgerState)
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
  -> Block era
  -- ^ Some block to apply
  -> Either LedgerStateError (LedgerState, [LedgerEvent])
  -- ^ The new ledger state (or an error).
applyBlock :: Env
-> LedgerState
-> ValidationMode
-> Block era
-> Either LedgerStateError (LedgerState, [LedgerEvent])
applyBlock Env
env LedgerState
oldState ValidationMode
validationMode Block era
block
  = Env
-> LedgerState
-> ValidationMode
-> HardForkBlock (CardanoEras StandardCrypto)
-> Either LedgerStateError (LedgerState, [LedgerEvent])
applyBlock' Env
env LedgerState
oldState ValidationMode
validationMode (HardForkBlock (CardanoEras StandardCrypto)
 -> Either LedgerStateError (LedgerState, [LedgerEvent]))
-> HardForkBlock (CardanoEras StandardCrypto)
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall a b. (a -> b) -> a -> b
$ case Block era
block of
      ByronBlock ByronBlock
byronBlock -> ByronBlock -> HardForkBlock (CardanoEras StandardCrypto)
forall c. ByronBlock -> CardanoBlock c
Consensus.BlockByron ByronBlock
byronBlock
      ShelleyBlock ShelleyBasedEra era
blockEra ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
shelleyBlock -> case ShelleyBasedEra era
blockEra of
        ShelleyBasedEra era
ShelleyBasedEraShelley -> ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
forall c. ShelleyBlock (TPraos c) (ShelleyEra c) -> CardanoBlock c
Consensus.BlockShelley ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto)
ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
shelleyBlock
        ShelleyBasedEra era
ShelleyBasedEraAllegra -> ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
forall c. ShelleyBlock (TPraos c) (AllegraEra c) -> CardanoBlock c
Consensus.BlockAllegra ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto)
ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
shelleyBlock
        ShelleyBasedEra era
ShelleyBasedEraMary    -> ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
forall c. ShelleyBlock (TPraos c) (MaryEra c) -> CardanoBlock c
Consensus.BlockMary ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto)
ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
shelleyBlock
        ShelleyBasedEra era
ShelleyBasedEraAlonzo  -> ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
forall c. ShelleyBlock (TPraos c) (AlonzoEra c) -> CardanoBlock c
Consensus.BlockAlonzo ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto)
ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
shelleyBlock
        ShelleyBasedEra era
ShelleyBasedEraBabbage -> ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
forall c. ShelleyBlock (Praos c) (BabbageEra c) -> CardanoBlock c
Consensus.BlockBabbage ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto)
ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)
shelleyBlock

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

pattern LedgerStateShelley
  :: Ledger.LedgerState (Shelley.ShelleyBlock protocol (Shelley.ShelleyEra Shelley.StandardCrypto))
  -> LedgerState
pattern $mLedgerStateShelley :: forall r.
LedgerState
-> (forall protocol.
    LedgerState (ShelleyBlock protocol (ShelleyEra StandardCrypto))
    -> r)
-> (Void# -> r)
-> r
LedgerStateShelley st <- LedgerState  (Consensus.LedgerStateShelley st)

pattern LedgerStateAllegra
  :: Ledger.LedgerState (Shelley.ShelleyBlock protocol (Shelley.AllegraEra Shelley.StandardCrypto))
  -> LedgerState
pattern $mLedgerStateAllegra :: forall r.
LedgerState
-> (forall protocol.
    LedgerState (ShelleyBlock protocol (AllegraEra StandardCrypto))
    -> r)
-> (Void# -> r)
-> r
LedgerStateAllegra st <- LedgerState  (Consensus.LedgerStateAllegra st)

pattern LedgerStateMary
  :: Ledger.LedgerState (Shelley.ShelleyBlock protocol (Shelley.MaryEra Shelley.StandardCrypto))
  -> LedgerState
pattern $mLedgerStateMary :: forall r.
LedgerState
-> (forall protocol.
    LedgerState (ShelleyBlock protocol (MaryEra StandardCrypto)) -> r)
-> (Void# -> r)
-> r
LedgerStateMary st <- LedgerState  (Consensus.LedgerStateMary st)

pattern LedgerStateAlonzo
  :: Ledger.LedgerState (Shelley.ShelleyBlock protocol (Shelley.AlonzoEra Shelley.StandardCrypto))
  -> LedgerState
pattern $mLedgerStateAlonzo :: forall r.
LedgerState
-> (forall protocol.
    LedgerState (ShelleyBlock protocol (AlonzoEra StandardCrypto))
    -> r)
-> (Void# -> r)
-> r
LedgerStateAlonzo st <- LedgerState  (Consensus.LedgerStateAlonzo st)

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

data FoldBlocksError
  = FoldBlocksInitialLedgerStateError InitialLedgerStateError
  | FoldBlocksApplyBlockError LedgerStateError

renderFoldBlocksError :: FoldBlocksError -> Text
renderFoldBlocksError :: FoldBlocksError -> Text
renderFoldBlocksError FoldBlocksError
fbe = case FoldBlocksError
fbe of
  FoldBlocksInitialLedgerStateError InitialLedgerStateError
err -> InitialLedgerStateError -> Text
renderInitialLedgerStateError InitialLedgerStateError
err
  FoldBlocksApplyBlockError LedgerStateError
err -> Text
"Failed when applying a block: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LedgerStateError -> Text
renderLedgerStateError LedgerStateError
err

-- | 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.
  FilePath
  -- ^ Path to the cardano-node config file (e.g. <path to cardano-node project>/configuration/cardano/mainnet-config.json)
  -> FilePath
  -- ^ 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 CardanoMode -> a -> IO a)
  -- ^ 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@
  --
  -- 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.
  -> ExceptT FoldBlocksError IO a
  -- ^ The final state
foldBlocks :: String
-> String
-> ValidationMode
-> a
-> (Env
    -> LedgerState
    -> [LedgerEvent]
    -> BlockInMode CardanoMode
    -> a
    -> IO a)
-> ExceptT FoldBlocksError IO a
foldBlocks String
nodeConfigFilePath String
socketPath ValidationMode
validationMode a
state0 Env
-> LedgerState
-> [LedgerEvent]
-> BlockInMode CardanoMode
-> a
-> IO a
accumulate = 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 (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT InitialLedgerStateError -> FoldBlocksError
FoldBlocksInitialLedgerStateError
                            (String -> ExceptT InitialLedgerStateError IO (Env, LedgerState)
initialLedgerState String
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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (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 bc _) :* NP WrapPartialLedgerConfig xs
_) -> Config
LedgerConfig ByronBlock
bc)
        (NP WrapPartialLedgerConfig (CardanoEras StandardCrypto) -> Config)
-> (HardForkLedgerConfig (CardanoEras StandardCrypto)
    -> NP WrapPartialLedgerConfig (CardanoEras StandardCrypto))
-> HardForkLedgerConfig (CardanoEras StandardCrypto)
-> Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerEraLedgerConfig (CardanoEras StandardCrypto)
-> NP WrapPartialLedgerConfig (CardanoEras StandardCrypto)
forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
HFC.getPerEraLedgerConfig
        (PerEraLedgerConfig (CardanoEras StandardCrypto)
 -> NP WrapPartialLedgerConfig (CardanoEras StandardCrypto))
-> (HardForkLedgerConfig (CardanoEras StandardCrypto)
    -> PerEraLedgerConfig (CardanoEras StandardCrypto))
-> HardForkLedgerConfig (CardanoEras StandardCrypto)
-> NP WrapPartialLedgerConfig (CardanoEras StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkLedgerConfig (CardanoEras StandardCrypto)
-> PerEraLedgerConfig (CardanoEras StandardCrypto)
forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
HFC.hardForkLedgerConfigPerEra
        (HardForkLedgerConfig (CardanoEras StandardCrypto) -> Config)
-> HardForkLedgerConfig (CardanoEras StandardCrypto) -> Config
forall a b. (a -> b) -> a -> b
$ Env -> HardForkLedgerConfig (CardanoEras 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 CardanoMode
cardanoModeParams = EpochSlots -> ConsensusModeParams CardanoMode
CardanoModeParams (EpochSlots -> ConsensusModeParams CardanoMode)
-> (Word64 -> EpochSlots)
-> Word64
-> ConsensusModeParams CardanoMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> EpochSlots
EpochSlots (Word64 -> ConsensusModeParams CardanoMode)
-> Word64 -> ConsensusModeParams CardanoMode
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 CardanoMode
      connectInfo :: LocalNodeConnectInfo CardanoMode
connectInfo =
          LocalNodeConnectInfo :: forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
LocalNodeConnectInfo {
            localConsensusModeParams :: ConsensusModeParams CardanoMode
localConsensusModeParams = ConsensusModeParams CardanoMode
cardanoModeParams,
            localNodeNetworkId :: NetworkId
localNodeNetworkId       = NetworkId
networkId',
            localNodeSocketPath :: String
localNodeSocketPath      = String
socketPath
          }

  IO () -> ExceptT FoldBlocksError IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT FoldBlocksError IO ())
-> IO () -> ExceptT FoldBlocksError IO ()
forall a b. (a -> b) -> a -> b
$ LocalNodeConnectInfo CardanoMode
-> LocalNodeClientProtocolsInMode CardanoMode -> IO ()
forall mode.
LocalNodeConnectInfo mode
-> LocalNodeClientProtocolsInMode mode -> IO ()
connectToLocalNode
    LocalNodeConnectInfo CardanoMode
connectInfo
    (IORef a
-> IORef (Maybe LedgerStateError)
-> Env
-> LedgerState
-> LocalNodeClientProtocolsInMode CardanoMode
protocols IORef a
stateIORef IORef (Maybe LedgerStateError)
errorIORef Env
env LedgerState
ledgerState)

  IO (Maybe LedgerStateError)
-> ExceptT FoldBlocksError IO (Maybe LedgerStateError)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just LedgerStateError
err -> FoldBlocksError -> ExceptT FoldBlocksError IO a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (LedgerStateError -> FoldBlocksError
FoldBlocksApplyBlockError LedgerStateError
err)
    Maybe LedgerStateError
Nothing -> IO a -> ExceptT FoldBlocksError IO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (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 CardanoMode
    protocols :: IORef a
-> IORef (Maybe LedgerStateError)
-> Env
-> LedgerState
-> LocalNodeClientProtocolsInMode CardanoMode
protocols IORef a
stateIORef IORef (Maybe LedgerStateError)
errorIORef Env
env LedgerState
ledgerState =
        LocalNodeClientProtocols :: forall block point tip slot tx txid txerr (query :: * -> *)
       (m :: * -> *).
LocalChainSyncClient block point tip m
-> Maybe (LocalTxSubmissionClient tx txerr m ())
-> Maybe (LocalStateQueryClient block point query m ())
-> Maybe (LocalTxMonitorClient txid tx slot m ())
-> LocalNodeClientProtocols
     block point tip slot tx txid txerr query m
LocalNodeClientProtocols {
          localChainSyncClient :: LocalChainSyncClient
  (BlockInMode CardanoMode) ChainPoint ChainTip IO
localChainSyncClient    = ChainSyncClientPipelined
  (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> LocalChainSyncClient
     (BlockInMode CardanoMode) ChainPoint ChainTip IO
forall block point tip (m :: * -> *).
ChainSyncClientPipelined block point tip m ()
-> LocalChainSyncClient block point tip m
LocalChainSyncClientPipelined (Word32
-> IORef a
-> IORef (Maybe LedgerStateError)
-> Env
-> LedgerState
-> ChainSyncClientPipelined
     (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
chainSyncClient Word32
50 IORef a
stateIORef IORef (Maybe LedgerStateError)
errorIORef Env
env LedgerState
ledgerState),
          localTxSubmissionClient :: Maybe
  (LocalTxSubmissionClient
     (TxInMode CardanoMode) (TxValidationErrorInMode CardanoMode) IO ())
localTxSubmissionClient = Maybe
  (LocalTxSubmissionClient
     (TxInMode CardanoMode) (TxValidationErrorInMode CardanoMode) IO ())
forall a. Maybe a
Nothing,
          localStateQueryClient :: Maybe
  (LocalStateQueryClient
     (BlockInMode CardanoMode)
     ChainPoint
     (QueryInMode CardanoMode)
     IO
     ())
localStateQueryClient   = Maybe
  (LocalStateQueryClient
     (BlockInMode CardanoMode)
     ChainPoint
     (QueryInMode CardanoMode)
     IO
     ())
forall a. Maybe a
Nothing,
          localTxMonitoringClient :: Maybe
  (LocalTxMonitorClient
     (TxIdInMode CardanoMode) (TxInMode CardanoMode) SlotNo IO ())
localTxMonitoringClient = Maybe
  (LocalTxMonitorClient
     (TxIdInMode CardanoMode) (TxInMode CardanoMode) SlotNo IO ())
forall a. Maybe a
Nothing
        }

    -- | Defines the client side of the chain sync protocol.
    chainSyncClient :: Word32
                    -- ^ The maximum number of concurrent requests.
                    -> IORef a
                    -> IORef (Maybe LedgerStateError)
                    -- ^ Resulting error if any. Written to once on protocol
                    -- completion.
                    -> Env
                    -> LedgerState
                    -> CSP.ChainSyncClientPipelined
                        (BlockInMode CardanoMode)
                        ChainPoint
                        ChainTip
                        IO ()
                    -- ^ Client returns maybe an error.
    chainSyncClient :: Word32
-> IORef a
-> IORef (Maybe LedgerStateError)
-> Env
-> LedgerState
-> ChainSyncClientPipelined
     (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
chainSyncClient Word32
pipelineSize IORef a
stateIORef IORef (Maybe LedgerStateError)
errorIORef Env
env LedgerState
ledgerState0
      = IO
  (ClientPipelinedStIdle
     'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
-> ChainSyncClientPipelined
     (BlockInMode CardanoMode) 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 CardanoMode) ChainPoint ChainTip IO ())
 -> ChainSyncClientPipelined
      (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
-> IO
     (ClientPipelinedStIdle
        'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
-> ChainSyncClientPipelined
     (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
forall a b. (a -> b) -> a -> b
$ ClientPipelinedStIdle
  'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle
        'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientPipelinedStIdle
   'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
 -> IO
      (ClientPipelinedStIdle
         'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ()))
-> ClientPipelinedStIdle
     'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle
        'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
forall a b. (a -> b) -> a -> b
$ WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat 'Z
-> LedgerStateHistory
-> ClientPipelinedStIdle
     'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) 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 LedgerStateHistory
initialLedgerStateHistory
      where
          initialLedgerStateHistory :: LedgerStateHistory
initialLedgerStateHistory = (SlotNo, (LedgerState, [LedgerEvent]),
 WithOrigin (BlockInMode CardanoMode))
-> LedgerStateHistory
forall a. a -> Seq a
Seq.singleton (SlotNo
0, (LedgerState
ledgerState0, []), WithOrigin (BlockInMode CardanoMode)
forall t. WithOrigin t
Origin)

          clientIdle_RequestMoreN
            :: WithOrigin BlockNo
            -> WithOrigin BlockNo
            -> Nat n -- Number of requests inflight.
            -> LedgerStateHistory
            -> CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
          clientIdle_RequestMoreN :: WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
clientTip WithOrigin BlockNo
serverTip Nat n
n LedgerStateHistory
knownLedgerStates
            = case Word32
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> PipelineDecision n
forall (n :: N).
Word32
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> PipelineDecision n
pipelineDecisionMax Word32
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 CardanoMode) ChainPoint ChainTip IO ()))
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> ClientPipelinedStIdle
     ('S n) (BlockInMode CardanoMode) 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 CardanoMode) ChainPoint ChainTip IO ()))
forall a. Maybe a
Nothing (Nat n
-> LedgerStateHistory
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
forall (n :: N).
Nat n
-> LedgerStateHistory
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientNextN Nat n
predN LedgerStateHistory
knownLedgerStates)
                PipelineDecision n
_ -> ClientPipelinedStIdle
  ('S n) (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
forall (n :: N) header point tip (m :: * -> *) a.
ClientPipelinedStIdle ('S n) header point tip m a
-> ClientPipelinedStIdle n header point tip m a
CSP.SendMsgRequestNextPipelined (WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat ('S n)
-> LedgerStateHistory
-> ClientPipelinedStIdle
     ('S n) (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) 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) LedgerStateHistory
knownLedgerStates)

          clientNextN
            :: Nat n -- Number of requests inflight.
            -> LedgerStateHistory
            -> CSP.ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
          clientNextN :: Nat n
-> LedgerStateHistory
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientNextN Nat n
n LedgerStateHistory
knownLedgerStates =
            ClientStNext :: 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 {
                recvMsgRollForward :: BlockInMode CardanoMode
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
CSP.recvMsgRollForward = \blockInMode :: BlockInMode CardanoMode
blockInMode@(BlockInMode block :: Block era
block@(Block (BlockHeader SlotNo
slotNo Hash BlockHeader
_ BlockNo
currBlockNo) [Tx era]
_) EraInMode era CardanoMode
_era) ChainTip
serverChainTip -> do
                  let newLedgerStateE :: Either LedgerStateError (LedgerState, [LedgerEvent])
newLedgerStateE = Env
-> LedgerState
-> ValidationMode
-> Block era
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall era.
Env
-> LedgerState
-> ValidationMode
-> Block era
-> Either LedgerStateError (LedgerState, [LedgerEvent])
applyBlock
                        Env
env
                        (LedgerState
-> ((SlotNo, (LedgerState, [LedgerEvent]),
     WithOrigin (BlockInMode CardanoMode))
    -> LedgerState)
-> Maybe
     (SlotNo, (LedgerState, [LedgerEvent]),
      WithOrigin (BlockInMode CardanoMode))
-> 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 CardanoMode)
_) -> LedgerState
ledgerState)
                          (Int
-> LedgerStateHistory
-> Maybe
     (SlotNo, (LedgerState, [LedgerEvent]),
      WithOrigin (BlockInMode CardanoMode))
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
0 LedgerStateHistory
knownLedgerStates)
                        )
                        ValidationMode
validationMode
                        Block era
block
                  case Either LedgerStateError (LedgerState, [LedgerEvent])
newLedgerStateE of
                    Left LedgerStateError
err -> Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n (LedgerStateError -> Maybe LedgerStateError
forall a. a -> Maybe a
Just LedgerStateError
err)
                    Right (LedgerState, [LedgerEvent])
newLedgerState -> do
                      let (LedgerStateHistory
knownLedgerStates', LedgerStateHistory
committedStates) = Env
-> LedgerStateHistory
-> SlotNo
-> (LedgerState, [LedgerEvent])
-> BlockInMode CardanoMode
-> (LedgerStateHistory, LedgerStateHistory)
forall a.
Env
-> History a
-> SlotNo
-> a
-> BlockInMode CardanoMode
-> (History a, History a)
pushLedgerState Env
env LedgerStateHistory
knownLedgerStates SlotNo
slotNo (LedgerState, [LedgerEvent])
newLedgerState BlockInMode CardanoMode
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
                      LedgerStateHistory
-> ((SlotNo, (LedgerState, [LedgerEvent]),
     WithOrigin (BlockInMode CardanoMode))
    -> IO ())
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ LedgerStateHistory
committedStates (((SlotNo, (LedgerState, [LedgerEvent]),
   WithOrigin (BlockInMode CardanoMode))
  -> IO ())
 -> IO ())
-> ((SlotNo, (LedgerState, [LedgerEvent]),
     WithOrigin (BlockInMode CardanoMode))
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(SlotNo
_, (LedgerState
ledgerState, [LedgerEvent]
ledgerEvents), WithOrigin (BlockInMode CardanoMode)
currBlockMay) -> case WithOrigin (BlockInMode CardanoMode)
currBlockMay of
                          WithOrigin (BlockInMode CardanoMode)
Origin -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                          At BlockInMode CardanoMode
currBlock -> do
                            a
newState <- Env
-> LedgerState
-> [LedgerEvent]
-> BlockInMode CardanoMode
-> a
-> IO a
accumulate
                              Env
env
                              LedgerState
ledgerState
                              [LedgerEvent]
ledgerEvents
                              BlockInMode CardanoMode
currBlock
                              (a -> IO a) -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
stateIORef
                            IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
stateIORef a
newState
                      if WithOrigin BlockNo
newClientTip WithOrigin BlockNo -> WithOrigin BlockNo -> Bool
forall a. Eq a => a -> a -> Bool
== WithOrigin BlockNo
newServerTip
                        then  Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n Maybe LedgerStateError
forall a. Maybe a
Nothing
                        else ClientPipelinedStIdle
  n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
newClientTip WithOrigin BlockNo
newServerTip Nat n
n LedgerStateHistory
knownLedgerStates')
              , recvMsgRollBackward :: ChainPoint
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) 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 :: LedgerStateHistory
truncatedKnownLedgerStates = case ChainPoint
chainPoint of
                          ChainPoint
ChainPointAtGenesis -> LedgerStateHistory
initialLedgerStateHistory
                          ChainPoint SlotNo
slotNo Hash BlockHeader
_ -> LedgerStateHistory -> SlotNo -> LedgerStateHistory
forall a. History a -> SlotNo -> History a
rollBackLedgerStateHist LedgerStateHistory
knownLedgerStates SlotNo
slotNo
                  ClientPipelinedStIdle
  n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
forall t. WithOrigin t
newClientTip WithOrigin BlockNo
newServerTip Nat n
n LedgerStateHistory
truncatedKnownLedgerStates)
              }

          clientIdle_DoneN
            :: Nat n -- Number of requests inflight.
            -> Maybe LedgerStateError -- Return value (maybe an error)
            -> IO (CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
          clientIdle_DoneN :: Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n Maybe LedgerStateError
errorMay = case Nat n
n of
            Succ Nat n
predN -> ClientPipelinedStIdle
  ('S n) (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle
        ('S n) (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
  (IO
     (ClientPipelinedStIdle
        ('S n) (BlockInMode CardanoMode) ChainPoint ChainTip IO ()))
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> ClientPipelinedStIdle
     ('S n) (BlockInMode CardanoMode) 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 CardanoMode) ChainPoint ChainTip IO ()))
forall a. Maybe a
Nothing (Nat n
-> Maybe LedgerStateError
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientNext_DoneN 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
  'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle
        'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (()
-> ClientPipelinedStIdle
     'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
forall a header point tip (m :: * -> *).
a -> ClientPipelinedStIdle 'Z header point tip m a
CSP.SendMsgDone ())

          clientNext_DoneN
            :: Nat n -- Number of requests inflight.
            -> Maybe LedgerStateError -- Return value (maybe an error)
            -> CSP.ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
          clientNext_DoneN :: Nat n
-> Maybe LedgerStateError
-> ClientStNext
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientNext_DoneN Nat n
n Maybe LedgerStateError
errorMay =
            ClientStNext :: 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 {
                recvMsgRollForward :: BlockInMode CardanoMode
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
CSP.recvMsgRollForward = \BlockInMode CardanoMode
_ ChainTip
_ -> Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n Maybe LedgerStateError
errorMay
              , recvMsgRollBackward :: ChainPoint
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
CSP.recvMsgRollBackward = \ChainPoint
_ ChainTip
_ -> Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe LedgerStateError
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
clientIdle_DoneN 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 CardanoMode, 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 CardanoMode)
                        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 :: Env
-> LedgerState
-> ValidationMode
-> ChainSyncClient
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ChainSyncClient
     (BlockInMode CardanoMode) ChainPoint ChainTip m a
chainSyncClientWithLedgerState Env
env LedgerState
ledgerState0 ValidationMode
validationMode (CS.ChainSyncClient m (ClientStIdle
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a)
clientTop)
  = m (ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> ChainSyncClient
     (BlockInMode CardanoMode) 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 (LedgerState, [LedgerEvent])))
-> ClientStIdle
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientStIdle (History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> Either
     LedgerStateError
     (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a b. b -> Either a b
Right History (Either LedgerStateError (LedgerState, [LedgerEvent]))
initialLedgerStateHistory) (ClientStIdle
   (BlockInMode CardanoMode,
    Either LedgerStateError (LedgerState, [LedgerEvent]))
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle
        (BlockInMode CardanoMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientStIdle
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a)
clientTop)
  where
    goClientStIdle
      :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents))
      -> CS.ClientStIdle (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a
      -> CS.ClientStIdle (BlockInMode CardanoMode                                                      ) ChainPoint ChainTip m a
    goClientStIdle :: Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> ClientStIdle
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientStIdle Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
history ClientStIdle
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
client = case ClientStIdle
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
client of
      CS.SendMsgRequestNext ClientStNext
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
a m (ClientStNext
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a)
b -> ClientStNext (BlockInMode CardanoMode) ChainPoint ChainTip m a
-> m (ClientStNext
        (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall header point tip (m :: * -> *) a.
ClientStNext header point tip m a
-> m (ClientStNext header point tip m a)
-> ClientStIdle header point tip m a
CS.SendMsgRequestNext (Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> ClientStNext
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientStNext Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
history ClientStNext
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
a) (Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> ClientStNext
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientStNext Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
history (ClientStNext
   (BlockInMode CardanoMode,
    Either LedgerStateError (LedgerState, [LedgerEvent]))
   ChainPoint
   ChainTip
   m
   a
 -> ClientStNext (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientStNext
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStNext
        (BlockInMode CardanoMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientStNext
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a)
b)
      CS.SendMsgFindIntersect [ChainPoint]
ps ClientStIntersect
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
a -> [ChainPoint]
-> ClientStIntersect
     (BlockInMode CardanoMode) ChainPoint ChainTip m a
-> ClientStIdle (BlockInMode CardanoMode) 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 (LedgerState, [LedgerEvent])))
-> ClientStIntersect
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStIntersect
     (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientStIntersect Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
history ClientStIntersect
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
a)
      CS.SendMsgDone a
a -> a -> ClientStIdle (BlockInMode CardanoMode) 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 CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a
      -> CS.ClientStNext (BlockInMode CardanoMode                                                      ) ChainPoint ChainTip m a
    goClientStNext :: Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> ClientStNext
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientStNext (Left LedgerStateError
err) (CS.ClientStNext (BlockInMode CardanoMode,
 Either LedgerStateError (LedgerState, [LedgerEvent]))
-> ChainTip
-> ChainSyncClient
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
recvMsgRollForward ChainPoint
-> ChainTip
-> ChainSyncClient
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
recvMsgRollBackward) = (BlockInMode CardanoMode
 -> ChainTip
 -> ChainSyncClient
      (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> (ChainPoint
    -> ChainTip
    -> ChainSyncClient
         (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> ClientStNext (BlockInMode CardanoMode) 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 CardanoMode
blkInMode ChainTip
tip -> m (ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> ChainSyncClient
     (BlockInMode CardanoMode) 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 CardanoMode) ChainPoint ChainTip m a)
 -> ChainSyncClient
      (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> ChainSyncClient
     (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall a b. (a -> b) -> a -> b
$
            Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> ClientStIdle
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientStIdle (LedgerStateError
-> Either
     LedgerStateError
     (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a b. a -> Either a b
Left LedgerStateError
err) (ClientStIdle
   (BlockInMode CardanoMode,
    Either LedgerStateError (LedgerState, [LedgerEvent]))
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle
        (BlockInMode CardanoMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClient
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
-> m (ClientStIdle
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        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 CardanoMode,
 Either LedgerStateError (LedgerState, [LedgerEvent]))
-> ChainTip
-> ChainSyncClient
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
recvMsgRollForward (BlockInMode CardanoMode
blkInMode, LedgerStateError
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall a b. a -> Either a b
Left LedgerStateError
err) ChainTip
tip)
      )
      (\ChainPoint
point ChainTip
tip -> m (ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> ChainSyncClient
     (BlockInMode CardanoMode) 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 CardanoMode) ChainPoint ChainTip m a)
 -> ChainSyncClient
      (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> ChainSyncClient
     (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall a b. (a -> b) -> a -> b
$
            Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> ClientStIdle
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientStIdle (LedgerStateError
-> Either
     LedgerStateError
     (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a b. a -> Either a b
Left LedgerStateError
err) (ClientStIdle
   (BlockInMode CardanoMode,
    Either LedgerStateError (LedgerState, [LedgerEvent]))
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle
        (BlockInMode CardanoMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClient
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
-> m (ClientStIdle
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        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 CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
recvMsgRollBackward ChainPoint
point ChainTip
tip)
      )
    goClientStNext (Right History (Either LedgerStateError (LedgerState, [LedgerEvent]))
history) (CS.ClientStNext (BlockInMode CardanoMode,
 Either LedgerStateError (LedgerState, [LedgerEvent]))
-> ChainTip
-> ChainSyncClient
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
recvMsgRollForward ChainPoint
-> ChainTip
-> ChainSyncClient
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
recvMsgRollBackward) = (BlockInMode CardanoMode
 -> ChainTip
 -> ChainSyncClient
      (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> (ChainPoint
    -> ChainTip
    -> ChainSyncClient
         (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> ClientStNext (BlockInMode CardanoMode) 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 CardanoMode
blkInMode@(BlockInMode blk :: Block era
blk@(Block (BlockHeader SlotNo
slotNo Hash BlockHeader
_ BlockNo
_) [Tx era]
_) EraInMode era CardanoMode
_) ChainTip
tip -> m (ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> ChainSyncClient
     (BlockInMode CardanoMode) 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 CardanoMode) ChainPoint ChainTip m a)
 -> ChainSyncClient
      (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> ChainSyncClient
     (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall a b. (a -> b) -> a -> b
$ let
          newLedgerStateE :: Either LedgerStateError (LedgerState, [LedgerEvent])
newLedgerStateE = case Int
-> History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> Maybe
     (SlotNo, Either LedgerStateError (LedgerState, [LedgerEvent]),
      WithOrigin (BlockInMode CardanoMode))
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
0 History (Either LedgerStateError (LedgerState, [LedgerEvent]))
history of
            Maybe
  (SlotNo, Either LedgerStateError (LedgerState, [LedgerEvent]),
   WithOrigin (BlockInMode CardanoMode))
Nothing -> String -> Either LedgerStateError (LedgerState, [LedgerEvent])
forall a. HasCallStack => String -> a
error String
"Impossible! History should always be non-empty"
            Just (SlotNo
_, Left LedgerStateError
err, WithOrigin (BlockInMode CardanoMode)
_) -> LedgerStateError
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall a b. a -> Either a b
Left LedgerStateError
err
            Just (SlotNo
_, Right (LedgerState
oldLedgerState, [LedgerEvent]
_), WithOrigin (BlockInMode CardanoMode)
_) -> Env
-> LedgerState
-> ValidationMode
-> Block era
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall era.
Env
-> LedgerState
-> ValidationMode
-> Block era
-> Either LedgerStateError (LedgerState, [LedgerEvent])
applyBlock
                  Env
env
                  LedgerState
oldLedgerState
                  ValidationMode
validationMode
                  Block era
blk
          (History (Either LedgerStateError (LedgerState, [LedgerEvent]))
history', History (Either LedgerStateError (LedgerState, [LedgerEvent]))
_) = Env
-> History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> SlotNo
-> Either LedgerStateError (LedgerState, [LedgerEvent])
-> BlockInMode CardanoMode
-> (History (Either LedgerStateError (LedgerState, [LedgerEvent])),
    History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a.
Env
-> History a
-> SlotNo
-> a
-> BlockInMode CardanoMode
-> (History a, History a)
pushLedgerState Env
env History (Either LedgerStateError (LedgerState, [LedgerEvent]))
history SlotNo
slotNo Either LedgerStateError (LedgerState, [LedgerEvent])
newLedgerStateE BlockInMode CardanoMode
blkInMode
          in Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> ClientStIdle
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientStIdle (History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> Either
     LedgerStateError
     (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a b. b -> Either a b
Right History (Either LedgerStateError (LedgerState, [LedgerEvent]))
history') (ClientStIdle
   (BlockInMode CardanoMode,
    Either LedgerStateError (LedgerState, [LedgerEvent]))
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle
        (BlockInMode CardanoMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClient
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
-> m (ClientStIdle
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        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 CardanoMode,
 Either LedgerStateError (LedgerState, [LedgerEvent]))
-> ChainTip
-> ChainSyncClient
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
recvMsgRollForward (BlockInMode CardanoMode
blkInMode, Either LedgerStateError (LedgerState, [LedgerEvent])
newLedgerStateE) ChainTip
tip)
      )
      (\ChainPoint
point ChainTip
tip -> let
          oldestSlot :: SlotNo
oldestSlot = case History (Either LedgerStateError (LedgerState, [LedgerEvent]))
history of
            History (Either LedgerStateError (LedgerState, [LedgerEvent]))
_ Seq.:|> (SlotNo
s, Either LedgerStateError (LedgerState, [LedgerEvent])
_, WithOrigin (BlockInMode CardanoMode)
_) -> SlotNo
s
            History (Either LedgerStateError (LedgerState, [LedgerEvent]))
Seq.Empty -> String -> SlotNo
forall a. HasCallStack => String -> a
error String
"Impossible! History should always be non-empty"
          history' :: Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
history' = (\History (Either LedgerStateError (LedgerState, [LedgerEvent]))
h -> if History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> Bool
forall a. Seq a -> Bool
Seq.null History (Either LedgerStateError (LedgerState, [LedgerEvent]))
h
                              then LedgerStateError
-> Either
     LedgerStateError
     (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a b. a -> Either a b
Left (SlotNo -> ChainPoint -> LedgerStateError
InvalidRollback SlotNo
oldestSlot ChainPoint
point)
                              else History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> Either
     LedgerStateError
     (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a b. b -> Either a b
Right History (Either LedgerStateError (LedgerState, [LedgerEvent]))
h)
                  (History (Either LedgerStateError (LedgerState, [LedgerEvent]))
 -> Either
      LedgerStateError
      (History (Either LedgerStateError (LedgerState, [LedgerEvent]))))
-> History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> Either
     LedgerStateError
     (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a b. (a -> b) -> a -> b
$ case ChainPoint
point of
                        ChainPoint
ChainPointAtGenesis -> History (Either LedgerStateError (LedgerState, [LedgerEvent]))
initialLedgerStateHistory
                        ChainPoint SlotNo
slotNo Hash BlockHeader
_ -> History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> SlotNo
-> History (Either LedgerStateError (LedgerState, [LedgerEvent]))
forall a. History a -> SlotNo -> History a
rollBackLedgerStateHist History (Either LedgerStateError (LedgerState, [LedgerEvent]))
history SlotNo
slotNo
        in m (ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> ChainSyncClient
     (BlockInMode CardanoMode) 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 CardanoMode) ChainPoint ChainTip m a)
 -> ChainSyncClient
      (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> ChainSyncClient
     (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall a b. (a -> b) -> a -> b
$ Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> ClientStIdle
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientStIdle Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
history' (ClientStIdle
   (BlockInMode CardanoMode,
    Either LedgerStateError (LedgerState, [LedgerEvent]))
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle
        (BlockInMode CardanoMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClient
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
-> m (ClientStIdle
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        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 CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
recvMsgRollBackward ChainPoint
point ChainTip
tip)
      )

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

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

-- | See 'chainSyncClientWithLedgerState'.
chainSyncClientPipelinedWithLedgerState
  :: forall m a.
     Monad m
  => Env
  -> LedgerState
  -> ValidationMode
  -> CSP.ChainSyncClientPipelined
                        (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent]))
                        ChainPoint
                        ChainTip
                        m
                        a
  -> CSP.ChainSyncClientPipelined
                        (BlockInMode CardanoMode)
                        ChainPoint
                        ChainTip
                        m
                        a
chainSyncClientPipelinedWithLedgerState :: Env
-> LedgerState
-> ValidationMode
-> ChainSyncClientPipelined
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ChainSyncClientPipelined
     (BlockInMode CardanoMode) ChainPoint ChainTip m a
chainSyncClientPipelinedWithLedgerState Env
env LedgerState
ledgerState0 ValidationMode
validationMode (CSP.ChainSyncClientPipelined m (ClientPipelinedStIdle
     'Z
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a)
clientTop)
  = m (ClientPipelinedStIdle
     'Z (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> ChainSyncClientPipelined
     (BlockInMode CardanoMode) 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 (LedgerState, [LedgerEvent])))
-> Nat 'Z
-> ClientPipelinedStIdle
     'Z
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     'Z (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientPipelinedStIdle (History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> Either
     LedgerStateError
     (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a b. b -> Either a b
Right History (Either LedgerStateError (LedgerState, [LedgerEvent]))
initialLedgerStateHistory) Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero (ClientPipelinedStIdle
   'Z
   (BlockInMode CardanoMode,
    Either LedgerStateError (LedgerState, [LedgerEvent]))
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle
      'Z (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        'Z
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle
        'Z (BlockInMode CardanoMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientPipelinedStIdle
     'Z
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a)
clientTop)
  where
    goClientPipelinedStIdle
      :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents))
      -> Nat n
      -> CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a
      -> CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode                                                      ) ChainPoint ChainTip m a
    goClientPipelinedStIdle :: Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientPipelinedStIdle Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
history Nat n
n ClientPipelinedStIdle
  n
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
client = case ClientPipelinedStIdle
  n
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
client of
      CSP.SendMsgRequestNext ClientStNext
  'Z
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
a m (ClientStNext
     'Z
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a)
b -> ClientStNext 'Z (BlockInMode CardanoMode) ChainPoint ChainTip m a
-> m (ClientStNext
        'Z (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> ClientPipelinedStIdle
     'Z (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall header point tip (m :: * -> *) a.
ClientStNext 'Z header point tip m a
-> m (ClientStNext 'Z header point tip m a)
-> ClientPipelinedStIdle 'Z header point tip m a
CSP.SendMsgRequestNext (Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientStNext
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientStNext
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientStNext Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
history Nat n
n ClientStNext
  n
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
ClientStNext
  'Z
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
a) (Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientStNext
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientStNext
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientStNext Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
history Nat n
n (ClientStNext
   n
   (BlockInMode CardanoMode,
    Either LedgerStateError (LedgerState, [LedgerEvent]))
   ChainPoint
   ChainTip
   m
   a
 -> ClientStNext
      n (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientStNext
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStNext
        n (BlockInMode CardanoMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientStNext
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a)
m (ClientStNext
     'Z
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a)
b)
      CSP.SendMsgRequestNextPipelined ClientPipelinedStIdle
  ('S n)
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
a ->  ClientPipelinedStIdle
  ('S n) (BlockInMode CardanoMode) ChainPoint ChainTip m a
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall (n :: N) header point tip (m :: * -> *) a.
ClientPipelinedStIdle ('S n) header point tip m a
-> ClientPipelinedStIdle n header point tip m a
CSP.SendMsgRequestNextPipelined (Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat ('S n)
-> ClientPipelinedStIdle
     ('S n)
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     ('S n) (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientPipelinedStIdle Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
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 CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
a)
      CSP.SendMsgFindIntersect [ChainPoint]
ps ClientPipelinedStIntersect
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
a -> [ChainPoint]
-> ClientPipelinedStIntersect
     (BlockInMode CardanoMode) ChainPoint ChainTip m a
-> ClientPipelinedStIdle
     'Z (BlockInMode CardanoMode) 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 (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIntersect
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIntersect
     (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIntersect
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIntersect
     (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientPipelinedStIntersect Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
history Nat n
n ClientPipelinedStIntersect
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
a)
      CSP.CollectResponse Maybe
  (m (ClientPipelinedStIdle
        ('S n1)
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a))
a ClientStNext
  n1
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
b -> case Nat n
n of
        Succ Nat n
nPrev -> Maybe
  (m (ClientPipelinedStIdle
        ('S n) (BlockInMode CardanoMode) ChainPoint ChainTip m a))
-> ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip m a
-> ClientPipelinedStIdle
     ('S n) (BlockInMode CardanoMode) 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
      n
      (BlockInMode CardanoMode,
       Either LedgerStateError (LedgerState, [LedgerEvent]))
      ChainPoint
      ChainTip
      m
      a)
 -> m (ClientPipelinedStIdle
         n (BlockInMode CardanoMode) ChainPoint ChainTip m a))
-> Maybe
     (m (ClientPipelinedStIdle
           n
           (BlockInMode CardanoMode,
            Either LedgerStateError (LedgerState, [LedgerEvent]))
           ChainPoint
           ChainTip
           m
           a))
-> Maybe
     (m (ClientPipelinedStIdle
           n (BlockInMode CardanoMode) ChainPoint ChainTip m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((m (ClientPipelinedStIdle
       n
       (BlockInMode CardanoMode,
        Either LedgerStateError (LedgerState, [LedgerEvent]))
       ChainPoint
       ChainTip
       m
       a)
  -> m (ClientPipelinedStIdle
          n (BlockInMode CardanoMode) ChainPoint ChainTip m a))
 -> Maybe
      (m (ClientPipelinedStIdle
            n
            (BlockInMode CardanoMode,
             Either LedgerStateError (LedgerState, [LedgerEvent]))
            ChainPoint
            ChainTip
            m
            a))
 -> Maybe
      (m (ClientPipelinedStIdle
            n (BlockInMode CardanoMode) ChainPoint ChainTip m a)))
-> ((ClientPipelinedStIdle
       n
       (BlockInMode CardanoMode,
        Either LedgerStateError (LedgerState, [LedgerEvent]))
       ChainPoint
       ChainTip
       m
       a
     -> ClientPipelinedStIdle
          n (BlockInMode CardanoMode) ChainPoint ChainTip m a)
    -> m (ClientPipelinedStIdle
            n
            (BlockInMode CardanoMode,
             Either LedgerStateError (LedgerState, [LedgerEvent]))
            ChainPoint
            ChainTip
            m
            a)
    -> m (ClientPipelinedStIdle
            n (BlockInMode CardanoMode) ChainPoint ChainTip m a))
-> (ClientPipelinedStIdle
      n
      (BlockInMode CardanoMode,
       Either LedgerStateError (LedgerState, [LedgerEvent]))
      ChainPoint
      ChainTip
      m
      a
    -> ClientPipelinedStIdle
         n (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> Maybe
     (m (ClientPipelinedStIdle
           n
           (BlockInMode CardanoMode,
            Either LedgerStateError (LedgerState, [LedgerEvent]))
           ChainPoint
           ChainTip
           m
           a))
-> Maybe
     (m (ClientPipelinedStIdle
           n (BlockInMode CardanoMode) ChainPoint ChainTip m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientPipelinedStIdle
   n
   (BlockInMode CardanoMode,
    Either LedgerStateError (LedgerState, [LedgerEvent]))
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle
      n (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientPipelinedStIdle Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
history Nat n
n) Maybe
  (m (ClientPipelinedStIdle
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a))
Maybe
  (m (ClientPipelinedStIdle
        ('S n1)
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a))
a) (Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientStNext
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientStNext
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientStNext Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
history Nat n
nPrev ClientStNext
  n1
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
ClientStNext
  n
  (BlockInMode CardanoMode,
   Either LedgerStateError (LedgerState, [LedgerEvent]))
  ChainPoint
  ChainTip
  m
  a
b)
      CSP.SendMsgDone a
a -> a
-> ClientPipelinedStIdle
     'Z (BlockInMode CardanoMode) 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 CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a
      -> CSP.ClientStNext n (BlockInMode CardanoMode                                                      ) ChainPoint ChainTip m a
    goClientStNext :: Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientStNext
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientStNext (Left LedgerStateError
err) Nat n
n (CSP.ClientStNext (BlockInMode CardanoMode,
 Either LedgerStateError (LedgerState, [LedgerEvent]))
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollForward ChainPoint
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollBackward) = (BlockInMode CardanoMode
 -> ChainTip
 -> m (ClientPipelinedStIdle
         n (BlockInMode CardanoMode) ChainPoint ChainTip m a))
-> (ChainPoint
    -> ChainTip
    -> m (ClientPipelinedStIdle
            n (BlockInMode CardanoMode) ChainPoint ChainTip m a))
-> ClientStNext n (BlockInMode CardanoMode) 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 CardanoMode
blkInMode ChainTip
tip ->
          Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientPipelinedStIdle (LedgerStateError
-> Either
     LedgerStateError
     (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a b. a -> Either a b
Left LedgerStateError
err) Nat n
n (ClientPipelinedStIdle
   n
   (BlockInMode CardanoMode,
    Either LedgerStateError (LedgerState, [LedgerEvent]))
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle
      n (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BlockInMode CardanoMode,
 Either LedgerStateError (LedgerState, [LedgerEvent]))
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollForward
            (BlockInMode CardanoMode
blkInMode, LedgerStateError
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall a b. a -> Either a b
Left LedgerStateError
err) ChainTip
tip
      )
      (\ChainPoint
point ChainTip
tip ->
          Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientPipelinedStIdle (LedgerStateError
-> Either
     LedgerStateError
     (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a b. a -> Either a b
Left LedgerStateError
err) Nat n
n (ClientPipelinedStIdle
   n
   (BlockInMode CardanoMode,
    Either LedgerStateError (LedgerState, [LedgerEvent]))
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle
      n (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainPoint
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollBackward ChainPoint
point ChainTip
tip
      )
    goClientStNext (Right History (Either LedgerStateError (LedgerState, [LedgerEvent]))
history) Nat n
n (CSP.ClientStNext (BlockInMode CardanoMode,
 Either LedgerStateError (LedgerState, [LedgerEvent]))
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollForward ChainPoint
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollBackward) = (BlockInMode CardanoMode
 -> ChainTip
 -> m (ClientPipelinedStIdle
         n (BlockInMode CardanoMode) ChainPoint ChainTip m a))
-> (ChainPoint
    -> ChainTip
    -> m (ClientPipelinedStIdle
            n (BlockInMode CardanoMode) ChainPoint ChainTip m a))
-> ClientStNext n (BlockInMode CardanoMode) 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 CardanoMode
blkInMode@(BlockInMode blk :: Block era
blk@(Block (BlockHeader SlotNo
slotNo Hash BlockHeader
_ BlockNo
_) [Tx era]
_) EraInMode era CardanoMode
_) ChainTip
tip -> let
          newLedgerStateE :: Either LedgerStateError (LedgerState, [LedgerEvent])
newLedgerStateE = case Int
-> History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> Maybe
     (SlotNo, Either LedgerStateError (LedgerState, [LedgerEvent]),
      WithOrigin (BlockInMode CardanoMode))
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
0 History (Either LedgerStateError (LedgerState, [LedgerEvent]))
history of
            Maybe
  (SlotNo, Either LedgerStateError (LedgerState, [LedgerEvent]),
   WithOrigin (BlockInMode CardanoMode))
Nothing -> String -> Either LedgerStateError (LedgerState, [LedgerEvent])
forall a. HasCallStack => String -> a
error String
"Impossible! History should always be non-empty"
            Just (SlotNo
_, Left LedgerStateError
err, WithOrigin (BlockInMode CardanoMode)
_) -> LedgerStateError
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall a b. a -> Either a b
Left LedgerStateError
err
            Just (SlotNo
_, Right (LedgerState
oldLedgerState, [LedgerEvent]
_), WithOrigin (BlockInMode CardanoMode)
_) -> Env
-> LedgerState
-> ValidationMode
-> Block era
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall era.
Env
-> LedgerState
-> ValidationMode
-> Block era
-> Either LedgerStateError (LedgerState, [LedgerEvent])
applyBlock
                  Env
env
                  LedgerState
oldLedgerState
                  ValidationMode
validationMode
                  Block era
blk
          (History (Either LedgerStateError (LedgerState, [LedgerEvent]))
history', History (Either LedgerStateError (LedgerState, [LedgerEvent]))
_) = Env
-> History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> SlotNo
-> Either LedgerStateError (LedgerState, [LedgerEvent])
-> BlockInMode CardanoMode
-> (History (Either LedgerStateError (LedgerState, [LedgerEvent])),
    History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a.
Env
-> History a
-> SlotNo
-> a
-> BlockInMode CardanoMode
-> (History a, History a)
pushLedgerState Env
env History (Either LedgerStateError (LedgerState, [LedgerEvent]))
history SlotNo
slotNo Either LedgerStateError (LedgerState, [LedgerEvent])
newLedgerStateE BlockInMode CardanoMode
blkInMode
        in Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientPipelinedStIdle (History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> Either
     LedgerStateError
     (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a b. b -> Either a b
Right History (Either LedgerStateError (LedgerState, [LedgerEvent]))
history') Nat n
n (ClientPipelinedStIdle
   n
   (BlockInMode CardanoMode,
    Either LedgerStateError (LedgerState, [LedgerEvent]))
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle
      n (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BlockInMode CardanoMode,
 Either LedgerStateError (LedgerState, [LedgerEvent]))
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollForward
              (BlockInMode CardanoMode
blkInMode, Either LedgerStateError (LedgerState, [LedgerEvent])
newLedgerStateE) ChainTip
tip
      )
      (\ChainPoint
point ChainTip
tip -> let
          oldestSlot :: SlotNo
oldestSlot = case History (Either LedgerStateError (LedgerState, [LedgerEvent]))
history of
            History (Either LedgerStateError (LedgerState, [LedgerEvent]))
_ Seq.:|> (SlotNo
s, Either LedgerStateError (LedgerState, [LedgerEvent])
_, WithOrigin (BlockInMode CardanoMode)
_) -> SlotNo
s
            History (Either LedgerStateError (LedgerState, [LedgerEvent]))
Seq.Empty -> String -> SlotNo
forall a. HasCallStack => String -> a
error String
"Impossible! History should always be non-empty"
          history' :: Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
history' = (\History (Either LedgerStateError (LedgerState, [LedgerEvent]))
h -> if History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> Bool
forall a. Seq a -> Bool
Seq.null History (Either LedgerStateError (LedgerState, [LedgerEvent]))
h
                              then LedgerStateError
-> Either
     LedgerStateError
     (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a b. a -> Either a b
Left (SlotNo -> ChainPoint -> LedgerStateError
InvalidRollback SlotNo
oldestSlot ChainPoint
point)
                              else History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> Either
     LedgerStateError
     (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a b. b -> Either a b
Right History (Either LedgerStateError (LedgerState, [LedgerEvent]))
h)
                  (History (Either LedgerStateError (LedgerState, [LedgerEvent]))
 -> Either
      LedgerStateError
      (History (Either LedgerStateError (LedgerState, [LedgerEvent]))))
-> History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> Either
     LedgerStateError
     (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
forall a b. (a -> b) -> a -> b
$ case ChainPoint
point of
                        ChainPoint
ChainPointAtGenesis -> History (Either LedgerStateError (LedgerState, [LedgerEvent]))
initialLedgerStateHistory
                        ChainPoint SlotNo
slotNo Hash BlockHeader
_ -> History (Either LedgerStateError (LedgerState, [LedgerEvent]))
-> SlotNo
-> History (Either LedgerStateError (LedgerState, [LedgerEvent]))
forall a. History a -> SlotNo -> History a
rollBackLedgerStateHist History (Either LedgerStateError (LedgerState, [LedgerEvent]))
history SlotNo
slotNo
        in Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip m a
forall (n :: N).
Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode CardanoMode,
      Either LedgerStateError (LedgerState, [LedgerEvent]))
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip m a
goClientPipelinedStIdle Either
  LedgerStateError
  (History (Either LedgerStateError (LedgerState, [LedgerEvent])))
history' Nat n
n (ClientPipelinedStIdle
   n
   (BlockInMode CardanoMode,
    Either LedgerStateError (LedgerState, [LedgerEvent]))
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle
      n (BlockInMode CardanoMode) ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainPoint
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode CardanoMode,
         Either LedgerStateError (LedgerState, [LedgerEvent]))
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollBackward ChainPoint
point ChainTip
tip
      )

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

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

{- 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 CardanoMode))

-- | 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 CardanoMode
                        -- ^ 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 :: Env
-> History a
-> SlotNo
-> a
-> BlockInMode CardanoMode
-> (History a, History a)
pushLedgerState Env
env History a
hist SlotNo
ix a
st BlockInMode CardanoMode
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
ix, a
st, BlockInMode CardanoMode -> WithOrigin (BlockInMode CardanoMode)
forall t. t -> WithOrigin t
At BlockInMode CardanoMode
block) (SlotNo, a, WithOrigin (BlockInMode CardanoMode))
-> History a -> History a
forall a. a -> Seq a -> Seq a
Seq.:<| History a
hist)

rollBackLedgerStateHist :: History a -> SlotNo -> History a
rollBackLedgerStateHist :: History a -> SlotNo -> History a
rollBackLedgerStateHist History a
hist SlotNo
maxInc = ((SlotNo, a, WithOrigin (BlockInMode CardanoMode)) -> 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 CardanoMode)) -> SlotNo)
-> (SlotNo, a, WithOrigin (BlockInMode CardanoMode))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(SlotNo
x,a
_,WithOrigin (BlockInMode CardanoMode)
_) -> 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 ShelleyConfig
sCfg AlonzoGenesis
_
        | 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 (ShelleyEra StandardCrypto) -> Word32
forall era. ShelleyGenesis era -> Word32
Shelley.Spec.sgNetworkMagic (ShelleyConfig -> ShelleyGenesis (ShelleyEra StandardCrypto)
scConfig ShelleyConfig
sCfg) ->
            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 (ShelleyEra StandardCrypto) -> Word32
forall era. ShelleyGenesis era -> Word32
Shelley.Spec.sgNetworkMagic (ShelleyGenesis (ShelleyEra StandardCrypto) -> Word32)
-> ShelleyGenesis (ShelleyEra StandardCrypto) -> Word32
forall a b. (a -> b) -> a -> b
$ ShelleyConfig -> ShelleyGenesis (ShelleyEra StandardCrypto)
scConfig ShelleyConfig
sCfg)
                ]
        | 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 (ShelleyEra StandardCrypto) -> UTCTime
forall era. ShelleyGenesis era -> UTCTime
Shelley.Spec.sgSystemStart (ShelleyConfig -> ShelleyGenesis (ShelleyEra StandardCrypto)
scConfig ShelleyConfig
sCfg) ->
            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 (ShelleyEra StandardCrypto) -> UTCTime
forall era. ShelleyGenesis era -> UTCTime
Shelley.Spec.sgSystemStart (ShelleyGenesis (ShelleyEra StandardCrypto) -> UTCTime)
-> ShelleyGenesis (ShelleyEra StandardCrypto) -> UTCTime
forall a b. (a -> b) -> a -> b
$ ShelleyConfig -> ShelleyGenesis (ShelleyEra StandardCrypto)
scConfig ShelleyConfig
sCfg)
                ]
        | Bool
otherwise ->
            let
              topLevelConfig :: TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
topLevelConfig = ProtocolInfo IO (HardForkBlock (CardanoEras StandardCrypto))
-> TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
forall (m :: * -> *) b. ProtocolInfo m b -> TopLevelConfig b
Consensus.pInfoConfig (GenesisConfig
-> ProtocolInfo IO (HardForkBlock (CardanoEras 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 :: HardForkLedgerConfig (CardanoEras StandardCrypto)
-> ConsensusConfig (HardForkProtocol (CardanoEras StandardCrypto))
-> Env
Env
                  { envLedgerConfig :: HardForkLedgerConfig (CardanoEras StandardCrypto)
envLedgerConfig = TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
-> LedgerConfig (HardForkBlock (CardanoEras StandardCrypto))
forall blk. TopLevelConfig blk -> LedgerConfig blk
Consensus.topLevelConfigLedger TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
topLevelConfig
                  , envProtocolConfig :: ConsensusConfig (HardForkProtocol (CardanoEras StandardCrypto))
envProtocolConfig = TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
-> ConsensusConfig
     (BlockProtocol (HardForkBlock (CardanoEras StandardCrypto)))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
Consensus.topLevelConfigProtocol TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
topLevelConfig
                  }

readNetworkConfig :: NetworkConfigFile -> ExceptT Text IO NodeConfig
readNetworkConfig :: NetworkConfigFile -> ExceptT Text IO NodeConfig
readNetworkConfig (NetworkConfigFile String
ncf) = do
    NodeConfig
ncfg <- (Either Text NodeConfig -> ExceptT Text IO NodeConfig
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either Text NodeConfig -> ExceptT Text IO NodeConfig)
-> (ByteString -> Either Text NodeConfig)
-> ByteString
-> ExceptT Text IO NodeConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text NodeConfig
parseNodeConfig) (ByteString -> ExceptT Text IO NodeConfig)
-> ExceptT Text IO ByteString -> ExceptT Text IO NodeConfig
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Text -> ExceptT Text IO ByteString
readByteString String
ncf Text
"node"
    NodeConfig -> ExceptT Text IO NodeConfig
forall (m :: * -> *) a. Monad m => a -> m a
return NodeConfig
ncfg
      { ncByronGenesisFile :: GenesisFile
ncByronGenesisFile = ShowS -> GenesisFile -> GenesisFile
adjustGenesisFilePath (String -> ShowS
mkAdjustPath String
ncf) (NodeConfig -> GenesisFile
ncByronGenesisFile NodeConfig
ncfg)
      , ncShelleyGenesisFile :: GenesisFile
ncShelleyGenesisFile = ShowS -> GenesisFile -> GenesisFile
adjustGenesisFilePath (String -> ShowS
mkAdjustPath String
ncf) (NodeConfig -> GenesisFile
ncShelleyGenesisFile NodeConfig
ncfg)
      , ncAlonzoGenesisFile :: GenesisFile
ncAlonzoGenesisFile = ShowS -> GenesisFile -> GenesisFile
adjustGenesisFilePath (String -> ShowS
mkAdjustPath String
ncf) (NodeConfig -> GenesisFile
ncAlonzoGenesisFile NodeConfig
ncfg)
      }

data NodeConfig = NodeConfig
  { NodeConfig -> Maybe Double
ncPBftSignatureThreshold :: !(Maybe Double)
  , NodeConfig -> GenesisFile
ncByronGenesisFile :: !GenesisFile
  , NodeConfig -> GenesisHashByron
ncByronGenesisHash :: !GenesisHashByron
  , NodeConfig -> GenesisFile
ncShelleyGenesisFile :: !GenesisFile
  , NodeConfig -> GenesisHashShelley
ncShelleyGenesisHash :: !GenesisHashShelley
  , NodeConfig -> GenesisFile
ncAlonzoGenesisFile :: !GenesisFile
  , NodeConfig -> GenesisHashAlonzo
ncAlonzoGenesisHash :: !GenesisHashAlonzo
  , NodeConfig -> RequiresNetworkMagic
ncRequiresNetworkMagic :: !Cardano.Crypto.RequiresNetworkMagic
  , NodeConfig -> SoftwareVersion
ncByronSoftwareVersion :: !Cardano.Chain.Update.SoftwareVersion
  , NodeConfig -> ProtocolVersion
ncByronProtocolVersion :: !Cardano.Chain.Update.ProtocolVersion

  -- Per-era parameters for the hardfok transitions:
  , NodeConfig
-> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
ncByronToShelley   :: !(Consensus.ProtocolTransitionParamsShelleyBased
                              Shelley.StandardShelley)
  , NodeConfig
-> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
ncShelleyToAllegra :: !(Consensus.ProtocolTransitionParamsShelleyBased
                              Shelley.StandardAllegra)
  , NodeConfig
-> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
ncAllegraToMary    :: !(Consensus.ProtocolTransitionParamsShelleyBased
                              Shelley.StandardMary)
  , NodeConfig -> TriggerHardFork
ncMaryToAlonzo     :: !Consensus.TriggerHardFork
  , NodeConfig -> TriggerHardFork
ncAlonzoToBabbage  :: !Consensus.TriggerHardFork
  }

instance FromJSON NodeConfig where
  parseJSON :: Value -> Parser NodeConfig
parseJSON Value
v =
      String
-> (Object -> Parser NodeConfig) -> Value -> Parser NodeConfig
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"NodeConfig" Object -> Parser NodeConfig
parse Value
v
    where
      parse :: Object -> Data.Aeson.Types.Internal.Parser NodeConfig
      parse :: Object -> Parser NodeConfig
parse Object
o =
        Maybe Double
-> GenesisFile
-> GenesisHashByron
-> GenesisFile
-> GenesisHashShelley
-> GenesisFile
-> GenesisHashAlonzo
-> RequiresNetworkMagic
-> SoftwareVersion
-> ProtocolVersion
-> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
-> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
-> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
-> TriggerHardFork
-> TriggerHardFork
-> NodeConfig
NodeConfig
          (Maybe Double
 -> GenesisFile
 -> GenesisHashByron
 -> GenesisFile
 -> GenesisHashShelley
 -> GenesisFile
 -> GenesisHashAlonzo
 -> RequiresNetworkMagic
 -> SoftwareVersion
 -> ProtocolVersion
 -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
 -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
 -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
 -> TriggerHardFork
 -> TriggerHardFork
 -> NodeConfig)
-> Parser (Maybe Double)
-> Parser
     (GenesisFile
      -> GenesisHashByron
      -> GenesisFile
      -> GenesisHashShelley
      -> GenesisFile
      -> GenesisHashAlonzo
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> TriggerHardFork
      -> 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
  (GenesisFile
   -> GenesisHashByron
   -> GenesisFile
   -> GenesisHashShelley
   -> GenesisFile
   -> GenesisHashAlonzo
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisFile
-> Parser
     (GenesisHashByron
      -> GenesisFile
      -> GenesisHashShelley
      -> GenesisFile
      -> GenesisHashAlonzo
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> GenesisFile) -> Parser String -> Parser GenesisFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> GenesisFile
GenesisFile (Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"ByronGenesisFile")
          Parser
  (GenesisHashByron
   -> GenesisFile
   -> GenesisHashShelley
   -> GenesisFile
   -> GenesisHashAlonzo
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisHashByron
-> Parser
     (GenesisFile
      -> GenesisHashShelley
      -> GenesisFile
      -> GenesisHashAlonzo
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> GenesisHashByron)
-> Parser Text -> Parser GenesisHashByron
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
  (GenesisFile
   -> GenesisHashShelley
   -> GenesisFile
   -> GenesisHashAlonzo
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisFile
-> Parser
     (GenesisHashShelley
      -> GenesisFile
      -> GenesisHashAlonzo
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> GenesisFile) -> Parser String -> Parser GenesisFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> GenesisFile
GenesisFile (Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"ShelleyGenesisFile")
          Parser
  (GenesisHashShelley
   -> GenesisFile
   -> GenesisHashAlonzo
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisHashShelley
-> Parser
     (GenesisFile
      -> GenesisHashAlonzo
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> TriggerHardFork
      -> NodeConfig)
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 (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
  (GenesisFile
   -> GenesisHashAlonzo
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisFile
-> Parser
     (GenesisHashAlonzo
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> GenesisFile) -> Parser String -> Parser GenesisFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> GenesisFile
GenesisFile (Object
o Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"AlonzoGenesisFile")
          Parser
  (GenesisHashAlonzo
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisHashAlonzo
-> Parser
     (RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> TriggerHardFork
      -> NodeConfig)
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 (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
  (RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> TriggerHardFork
   -> NodeConfig)
-> Parser RequiresNetworkMagic
-> Parser
     (SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> TriggerHardFork
      -> NodeConfig)
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
  (SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> TriggerHardFork
   -> NodeConfig)
-> Parser SoftwareVersion
-> Parser
     (ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser SoftwareVersion
parseByronSoftwareVersion Object
o
          Parser
  (ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> TriggerHardFork
   -> NodeConfig)
-> Parser ProtocolVersion
-> Parser
     (ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser ProtocolVersion
parseByronProtocolVersion Object
o
          Parser
  (ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> TriggerHardFork
   -> NodeConfig)
-> Parser
     (ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto))
-> Parser
     (ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TranslationContext (ShelleyEra StandardCrypto)
-> TriggerHardFork
-> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
forall era.
TranslationContext era
-> TriggerHardFork -> ProtocolTransitionParamsShelleyBased era
Consensus.ProtocolTransitionParamsShelleyBased ()
                 (TriggerHardFork
 -> ProtocolTransitionParamsShelleyBased
      (ShelleyEra StandardCrypto))
-> Parser TriggerHardFork
-> Parser
     (ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser TriggerHardFork
parseShelleyHardForkEpoch Object
o)
          Parser
  (ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> TriggerHardFork
   -> NodeConfig)
-> Parser
     (ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto))
-> Parser
     (ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork -> TriggerHardFork -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TranslationContext (AllegraEra StandardCrypto)
-> TriggerHardFork
-> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
forall era.
TranslationContext era
-> TriggerHardFork -> ProtocolTransitionParamsShelleyBased era
Consensus.ProtocolTransitionParamsShelleyBased ()
                 (TriggerHardFork
 -> ProtocolTransitionParamsShelleyBased
      (AllegraEra StandardCrypto))
-> Parser TriggerHardFork
-> Parser
     (ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser TriggerHardFork
parseAllegraHardForkEpoch Object
o)
          Parser
  (ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork -> TriggerHardFork -> NodeConfig)
-> Parser
     (ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto))
-> Parser (TriggerHardFork -> TriggerHardFork -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TranslationContext (MaryEra StandardCrypto)
-> TriggerHardFork
-> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
forall era.
TranslationContext era
-> TriggerHardFork -> ProtocolTransitionParamsShelleyBased era
Consensus.ProtocolTransitionParamsShelleyBased ()
                 (TriggerHardFork
 -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto))
-> Parser TriggerHardFork
-> Parser
     (ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser TriggerHardFork
parseMaryHardForkEpoch Object
o)
          Parser (TriggerHardFork -> TriggerHardFork -> NodeConfig)
-> Parser TriggerHardFork -> Parser (TriggerHardFork -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser TriggerHardFork
parseAlonzoHardForkEpoch Object
o
          Parser (TriggerHardFork -> NodeConfig)
-> Parser TriggerHardFork -> Parser NodeConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser TriggerHardFork
parseBabbageHardForkEpoch Object
o

      parseByronProtocolVersion :: Object -> Data.Aeson.Types.Internal.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 (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 (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"

      parseByronSoftwareVersion :: Object -> Data.Aeson.Types.Internal.Parser Cardano.Chain.Update.SoftwareVersion
      parseByronSoftwareVersion :: Object -> Parser SoftwareVersion
parseByronSoftwareVersion Object
o =
        ApplicationName -> Word32 -> SoftwareVersion
Cardano.Chain.Update.SoftwareVersion
          (ApplicationName -> Word32 -> SoftwareVersion)
-> Parser ApplicationName -> Parser (Word32 -> SoftwareVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> ApplicationName) -> Parser Text -> Parser ApplicationName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ApplicationName
Cardano.Chain.Update.ApplicationName (Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"ApplicationName")
          Parser (Word32 -> SoftwareVersion)
-> Parser Word32 -> Parser SoftwareVersion
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Word32
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"ApplicationVersion"

      parseShelleyHardForkEpoch :: Object -> Data.Aeson.Types.Internal.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 (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 -> Data.Aeson.Types.Internal.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 (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 -> Data.Aeson.Types.Internal.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 (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 -> Data.Aeson.Types.Internal.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 (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 -> Data.Aeson.Types.Internal.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 (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
          ]

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

adjustGenesisFilePath :: (FilePath -> FilePath) -> GenesisFile -> GenesisFile
adjustGenesisFilePath :: ShowS -> GenesisFile -> GenesisFile
adjustGenesisFilePath ShowS
f (GenesisFile String
p) = String -> GenesisFile
GenesisFile (ShowS
f String
p)

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

readByteString :: FilePath -> Text -> ExceptT Text IO ByteString
readByteString :: String -> Text -> ExceptT Text IO ByteString
readByteString String
fp Text
cfgType = IO (Either Text ByteString) -> ExceptT Text IO ByteString
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either Text ByteString) -> ExceptT Text IO ByteString)
-> IO (Either Text ByteString) -> ExceptT Text IO ByteString
forall a b. (a -> b) -> a -> b
$
  IO (Either Text ByteString)
-> (IOException -> IO (Either Text ByteString))
-> IO (Either Text ByteString)
forall e a. Exception e => IO a -> (e -> IO a) -> IO 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 (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 :: LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> LedgerState
LedgerState
  { clsState :: LedgerState (HardForkBlock (CardanoEras StandardCrypto))
clsState = ExtLedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
forall blk. ExtLedgerState blk -> LedgerState blk
Ledger.ledgerState (ExtLedgerState (HardForkBlock (CardanoEras StandardCrypto))
 -> LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> ExtLedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
forall a b. (a -> b) -> a -> b
$ ProtocolInfo IO (HardForkBlock (CardanoEras StandardCrypto))
-> ExtLedgerState (HardForkBlock (CardanoEras StandardCrypto))
forall (m :: * -> *) b. ProtocolInfo m b -> ExtLedgerState b
Consensus.pInfoInitLedger ProtocolInfo IO (HardForkBlock (CardanoEras StandardCrypto))
protocolInfo
  }
  where
    protocolInfo :: ProtocolInfo IO (HardForkBlock (CardanoEras StandardCrypto))
protocolInfo = GenesisConfig
-> ProtocolInfo IO (HardForkBlock (CardanoEras StandardCrypto))
mkProtocolInfoCardano GenesisConfig
genesisConfig

newtype LedgerState = LedgerState
  { LedgerState
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
clsState :: Ledger.LedgerState
                  (HFC.HardForkBlock
                    (Consensus.CardanoEras Consensus.StandardCrypto))
  }

type LedgerStateEvents = (LedgerState, [LedgerEvent])

toLedgerStateEvents ::
  LedgerResult
    ( Shelley.LedgerState
        (HFC.HardForkBlock (Consensus.CardanoEras Shelley.StandardCrypto))
    )
    ( Shelley.LedgerState
        (HFC.HardForkBlock (Consensus.CardanoEras Shelley.StandardCrypto))
    ) ->
  LedgerStateEvents
toLedgerStateEvents :: LedgerResult
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> (LedgerState, [LedgerEvent])
toLedgerStateEvents LedgerResult
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
lr = (LedgerState
ledgerState, [LedgerEvent]
ledgerEvents)
  where
    ledgerState :: LedgerState
ledgerState = LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> LedgerState
LedgerState (LedgerResult
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
forall l a. LedgerResult l a -> a
lrResult LedgerResult
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
lr)
    ledgerEvents :: [LedgerEvent]
ledgerEvents = (OneEraLedgerEvent (CardanoEras StandardCrypto)
 -> Maybe LedgerEvent)
-> [OneEraLedgerEvent (CardanoEras StandardCrypto)]
-> [LedgerEvent]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (WrapLedgerEvent (HardForkBlock (CardanoEras StandardCrypto))
-> Maybe LedgerEvent
forall blk.
ConvertLedgerEvent blk =>
WrapLedgerEvent blk -> Maybe LedgerEvent
toLedgerEvent
      (WrapLedgerEvent (HardForkBlock (CardanoEras StandardCrypto))
 -> Maybe LedgerEvent)
-> (OneEraLedgerEvent (CardanoEras StandardCrypto)
    -> WrapLedgerEvent (HardForkBlock (CardanoEras StandardCrypto)))
-> OneEraLedgerEvent (CardanoEras StandardCrypto)
-> Maybe LedgerEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuxLedgerEvent
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> WrapLedgerEvent (HardForkBlock (CardanoEras StandardCrypto))
forall blk. AuxLedgerEvent (LedgerState blk) -> WrapLedgerEvent blk
WrapLedgerEvent @(HFC.HardForkBlock (Consensus.CardanoEras Shelley.StandardCrypto)))
      ([OneEraLedgerEvent (CardanoEras StandardCrypto)] -> [LedgerEvent])
-> [OneEraLedgerEvent (CardanoEras StandardCrypto)]
-> [LedgerEvent]
forall a b. (a -> b) -> a -> b
$ LedgerResult
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> [AuxLedgerEvent
      (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))]
forall l a. LedgerResult l a -> [AuxLedgerEvent l]
lrEvents LedgerResult
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
  (LedgerState (HardForkBlock (CardanoEras 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
      !ShelleyConfig
      !AlonzoGenesis

data ShelleyConfig = ShelleyConfig
  { ShelleyConfig -> ShelleyGenesis (ShelleyEra StandardCrypto)
scConfig :: !(Shelley.Spec.ShelleyGenesis Shelley.StandardShelley)
  , ShelleyConfig -> GenesisHashShelley
scGenesisHash :: !GenesisHashShelley
  }

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

newtype GenesisHashByron = GenesisHashByron
  { GenesisHashByron -> Text
unGenesisHashByron :: Text
  } deriving newtype (GenesisHashByron -> GenesisHashByron -> Bool
(GenesisHashByron -> GenesisHashByron -> Bool)
-> (GenesisHashByron -> GenesisHashByron -> Bool)
-> Eq GenesisHashByron
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenesisHashByron -> GenesisHashByron -> Bool
$c/= :: GenesisHashByron -> GenesisHashByron -> Bool
== :: GenesisHashByron -> GenesisHashByron -> Bool
$c== :: GenesisHashByron -> GenesisHashByron -> Bool
Eq, Int -> GenesisHashByron -> ShowS
[GenesisHashByron] -> ShowS
GenesisHashByron -> String
(Int -> GenesisHashByron -> ShowS)
-> (GenesisHashByron -> String)
-> ([GenesisHashByron] -> ShowS)
-> Show GenesisHashByron
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenesisHashByron] -> ShowS
$cshowList :: [GenesisHashByron] -> ShowS
show :: GenesisHashByron -> String
$cshow :: GenesisHashByron -> String
showsPrec :: Int -> GenesisHashByron -> ShowS
$cshowsPrec :: Int -> GenesisHashByron -> ShowS
Show)

newtype GenesisHashShelley = GenesisHashShelley
  { GenesisHashShelley -> Hash Blake2b_256 ByteString
unGenesisHashShelley :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 ByteString
  } deriving newtype (GenesisHashShelley -> GenesisHashShelley -> Bool
(GenesisHashShelley -> GenesisHashShelley -> Bool)
-> (GenesisHashShelley -> GenesisHashShelley -> Bool)
-> Eq GenesisHashShelley
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenesisHashShelley -> GenesisHashShelley -> Bool
$c/= :: GenesisHashShelley -> GenesisHashShelley -> Bool
== :: GenesisHashShelley -> GenesisHashShelley -> Bool
$c== :: GenesisHashShelley -> GenesisHashShelley -> Bool
Eq, Int -> GenesisHashShelley -> ShowS
[GenesisHashShelley] -> ShowS
GenesisHashShelley -> String
(Int -> GenesisHashShelley -> ShowS)
-> (GenesisHashShelley -> String)
-> ([GenesisHashShelley] -> ShowS)
-> Show GenesisHashShelley
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenesisHashShelley] -> ShowS
$cshowList :: [GenesisHashShelley] -> ShowS
show :: GenesisHashShelley -> String
$cshow :: GenesisHashShelley -> String
showsPrec :: Int -> GenesisHashShelley -> ShowS
$cshowsPrec :: Int -> GenesisHashShelley -> ShowS
Show)

newtype GenesisHashAlonzo = GenesisHashAlonzo
  { GenesisHashAlonzo -> Hash Blake2b_256 ByteString
unGenesisHashAlonzo :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 ByteString
  } deriving newtype (GenesisHashAlonzo -> GenesisHashAlonzo -> Bool
(GenesisHashAlonzo -> GenesisHashAlonzo -> Bool)
-> (GenesisHashAlonzo -> GenesisHashAlonzo -> Bool)
-> Eq GenesisHashAlonzo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenesisHashAlonzo -> GenesisHashAlonzo -> Bool
$c/= :: GenesisHashAlonzo -> GenesisHashAlonzo -> Bool
== :: GenesisHashAlonzo -> GenesisHashAlonzo -> Bool
$c== :: GenesisHashAlonzo -> GenesisHashAlonzo -> Bool
Eq, Int -> GenesisHashAlonzo -> ShowS
[GenesisHashAlonzo] -> ShowS
GenesisHashAlonzo -> String
(Int -> GenesisHashAlonzo -> ShowS)
-> (GenesisHashAlonzo -> String)
-> ([GenesisHashAlonzo] -> ShowS)
-> Show GenesisHashAlonzo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenesisHashAlonzo] -> ShowS
$cshowList :: [GenesisHashAlonzo] -> ShowS
show :: GenesisHashAlonzo -> String
$cshow :: GenesisHashAlonzo -> String
showsPrec :: Int -> GenesisHashAlonzo -> ShowS
$cshowsPrec :: Int -> GenesisHashAlonzo -> ShowS
Show)

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
showList :: [LedgerStateDir] -> ShowS
$cshowList :: [LedgerStateDir] -> ShowS
show :: LedgerStateDir -> String
$cshow :: LedgerStateDir -> String
showsPrec :: Int -> LedgerStateDir -> ShowS
$cshowsPrec :: Int -> 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
showList :: [NetworkName] -> ShowS
$cshowList :: [NetworkName] -> ShowS
show :: NetworkName -> String
$cshow :: NetworkName -> String
showsPrec :: Int -> NetworkName -> ShowS
$cshowsPrec :: Int -> NetworkName -> ShowS
Show

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

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

mkProtocolInfoCardano ::
  GenesisConfig ->
  Consensus.ProtocolInfo
    IO
    (HFC.HardForkBlock
            (Consensus.CardanoEras Consensus.StandardCrypto))
mkProtocolInfoCardano :: GenesisConfig
-> ProtocolInfo IO (HardForkBlock (CardanoEras StandardCrypto))
mkProtocolInfoCardano (GenesisCardano NodeConfig
dnc Config
byronGenesis ShelleyConfig
shelleyGenesis AlonzoGenesis
alonzoGenesis)
  = ProtocolParamsByron
-> ProtocolParamsShelleyBased (ShelleyEra StandardCrypto)
-> ProtocolParamsShelley StandardCrypto
-> ProtocolParamsAllegra StandardCrypto
-> ProtocolParamsMary StandardCrypto
-> ProtocolParamsAlonzo StandardCrypto
-> ProtocolParamsBabbage StandardCrypto
-> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
-> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
-> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
-> ProtocolTransitionParamsShelleyBased (AlonzoEra StandardCrypto)
-> ProtocolTransitionParamsShelleyBased (BabbageEra StandardCrypto)
-> ProtocolInfo IO (HardForkBlock (CardanoEras StandardCrypto))
forall c (m :: * -> *).
(IOLike m, CardanoHardForkConstraints c) =>
ProtocolParamsByron
-> ProtocolParamsShelleyBased (ShelleyEra c)
-> ProtocolParamsShelley c
-> ProtocolParamsAllegra c
-> ProtocolParamsMary c
-> ProtocolParamsAlonzo c
-> ProtocolParamsBabbage c
-> ProtocolTransitionParamsShelleyBased (ShelleyEra c)
-> ProtocolTransitionParamsShelleyBased (AllegraEra c)
-> ProtocolTransitionParamsShelleyBased (MaryEra c)
-> ProtocolTransitionParamsShelleyBased (AlonzoEra c)
-> ProtocolTransitionParamsShelleyBased (BabbageEra c)
-> ProtocolInfo m (CardanoBlock c)
Consensus.protocolInfoCardano
          ProtocolParamsByron :: Config
-> Maybe PBftSignatureThreshold
-> ProtocolVersion
-> SoftwareVersion
-> Maybe ByronLeaderCredentials
-> Overrides ByronBlock
-> ProtocolParamsByron
Consensus.ProtocolParamsByron
            { $sel:byronGenesis:ProtocolParamsByron :: Config
Consensus.byronGenesis = Config
byronGenesis
            , $sel:byronPbftSignatureThreshold:ProtocolParamsByron :: 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
            , $sel:byronProtocolVersion:ProtocolParamsByron :: ProtocolVersion
Consensus.byronProtocolVersion = NodeConfig -> ProtocolVersion
ncByronProtocolVersion NodeConfig
dnc
            , $sel:byronSoftwareVersion:ProtocolParamsByron :: SoftwareVersion
Consensus.byronSoftwareVersion = NodeConfig -> SoftwareVersion
ncByronSoftwareVersion NodeConfig
dnc
            , $sel:byronLeaderCredentials:ProtocolParamsByron :: Maybe ByronLeaderCredentials
Consensus.byronLeaderCredentials = Maybe ByronLeaderCredentials
forall a. Maybe a
Nothing
            , $sel:byronMaxTxCapacityOverrides:ProtocolParamsByron :: Overrides ByronBlock
Consensus.byronMaxTxCapacityOverrides = TxMeasure ByronBlock -> Overrides ByronBlock
forall blk. TxMeasure blk -> Overrides blk
TxLimits.mkOverrides TxMeasure ByronBlock
forall a. BoundedMeasure a => a
TxLimits.noOverridesMeasure
            }
          ProtocolParamsShelleyBased :: forall era.
ShelleyGenesis era
-> Nonce
-> [ShelleyLeaderCredentials (EraCrypto era)]
-> ProtocolParamsShelleyBased era
Consensus.ProtocolParamsShelleyBased
            { shelleyBasedGenesis :: ShelleyGenesis (ShelleyEra StandardCrypto)
Consensus.shelleyBasedGenesis = ShelleyConfig -> ShelleyGenesis (ShelleyEra StandardCrypto)
scConfig ShelleyConfig
shelleyGenesis
            , shelleyBasedInitialNonce :: Nonce
Consensus.shelleyBasedInitialNonce = ShelleyConfig -> Nonce
shelleyPraosNonce ShelleyConfig
shelleyGenesis
            , shelleyBasedLeaderCredentials :: [ShelleyLeaderCredentials (EraCrypto (ShelleyEra StandardCrypto))]
Consensus.shelleyBasedLeaderCredentials = []
            }
          ProtocolParamsShelley :: forall c.
ProtVer
-> Overrides (ShelleyBlock (TPraos c) (ShelleyEra c))
-> ProtocolParamsShelley c
Consensus.ProtocolParamsShelley
            { $sel:shelleyProtVer:ProtocolParamsShelley :: ProtVer
Consensus.shelleyProtVer = NodeConfig -> ProtVer
shelleyProtVer NodeConfig
dnc
            , $sel:shelleyMaxTxCapacityOverrides:ProtocolParamsShelley :: Overrides
  (ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto))
Consensus.shelleyMaxTxCapacityOverrides = TxMeasure
  (ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto))
-> Overrides
     (ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto))
forall blk. TxMeasure blk -> Overrides blk
TxLimits.mkOverrides TxMeasure
  (ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto))
forall a. BoundedMeasure a => a
TxLimits.noOverridesMeasure
            }
          ProtocolParamsAllegra :: forall c.
ProtVer
-> Overrides (ShelleyBlock (TPraos c) (AllegraEra c))
-> ProtocolParamsAllegra c
Consensus.ProtocolParamsAllegra
            { $sel:allegraProtVer:ProtocolParamsAllegra :: ProtVer
Consensus.allegraProtVer = NodeConfig -> ProtVer
shelleyProtVer NodeConfig
dnc
            , $sel:allegraMaxTxCapacityOverrides:ProtocolParamsAllegra :: Overrides
  (ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto))
Consensus.allegraMaxTxCapacityOverrides = TxMeasure
  (ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto))
-> Overrides
     (ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto))
forall blk. TxMeasure blk -> Overrides blk
TxLimits.mkOverrides TxMeasure
  (ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto))
forall a. BoundedMeasure a => a
TxLimits.noOverridesMeasure
            }
          ProtocolParamsMary :: forall c.
ProtVer
-> Overrides (ShelleyBlock (TPraos c) (MaryEra c))
-> ProtocolParamsMary c
Consensus.ProtocolParamsMary
            { $sel:maryProtVer:ProtocolParamsMary :: ProtVer
Consensus.maryProtVer = NodeConfig -> ProtVer
shelleyProtVer NodeConfig
dnc
            , $sel:maryMaxTxCapacityOverrides:ProtocolParamsMary :: Overrides
  (ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto))
Consensus.maryMaxTxCapacityOverrides = TxMeasure
  (ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto))
-> Overrides
     (ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto))
forall blk. TxMeasure blk -> Overrides blk
TxLimits.mkOverrides TxMeasure
  (ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto))
forall a. BoundedMeasure a => a
TxLimits.noOverridesMeasure
            }
          ProtocolParamsAlonzo :: forall c.
ProtVer
-> Overrides (ShelleyBlock (TPraos c) (AlonzoEra c))
-> ProtocolParamsAlonzo c
Consensus.ProtocolParamsAlonzo
            { $sel:alonzoProtVer:ProtocolParamsAlonzo :: ProtVer
Consensus.alonzoProtVer = NodeConfig -> ProtVer
shelleyProtVer NodeConfig
dnc
            , $sel:alonzoMaxTxCapacityOverrides:ProtocolParamsAlonzo :: Overrides
  (ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto))
Consensus.alonzoMaxTxCapacityOverrides  = TxMeasure
  (ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto))
-> Overrides
     (ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto))
forall blk. TxMeasure blk -> Overrides blk
TxLimits.mkOverrides TxMeasure
  (ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto))
forall a. BoundedMeasure a => a
TxLimits.noOverridesMeasure
            }
          ProtocolParamsBabbage :: forall c.
ProtVer
-> Overrides (ShelleyBlock (Praos c) (BabbageEra c))
-> ProtocolParamsBabbage c
Consensus.ProtocolParamsBabbage
            { babbageProtVer :: ProtVer
Consensus.babbageProtVer = NodeConfig -> ProtVer
shelleyProtVer NodeConfig
dnc
            , babbageMaxTxCapacityOverrides :: Overrides
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
Consensus.babbageMaxTxCapacityOverrides = TxMeasure
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
-> Overrides
     (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
forall blk. TxMeasure blk -> Overrides blk
TxLimits.mkOverrides TxMeasure
  (ShelleyBlock (Praos StandardCrypto) (BabbageEra StandardCrypto))
forall a. BoundedMeasure a => a
TxLimits.noOverridesMeasure
            }
          (NodeConfig
-> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
ncByronToShelley NodeConfig
dnc)
          (NodeConfig
-> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
ncShelleyToAllegra NodeConfig
dnc)
          (NodeConfig
-> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
ncAllegraToMary NodeConfig
dnc)
          (TranslationContext (AlonzoEra StandardCrypto)
-> TriggerHardFork
-> ProtocolTransitionParamsShelleyBased (AlonzoEra StandardCrypto)
forall era.
TranslationContext era
-> TriggerHardFork -> ProtocolTransitionParamsShelleyBased era
Consensus.ProtocolTransitionParamsShelleyBased AlonzoGenesis
TranslationContext (AlonzoEra StandardCrypto)
alonzoGenesis (NodeConfig -> TriggerHardFork
ncMaryToAlonzo NodeConfig
dnc))
          (TranslationContext (BabbageEra StandardCrypto)
-> TriggerHardFork
-> ProtocolTransitionParamsShelleyBased (BabbageEra StandardCrypto)
forall era.
TranslationContext era
-> TriggerHardFork -> ProtocolTransitionParamsShelleyBased era
Consensus.ProtocolTransitionParamsShelleyBased AlonzoGenesis
TranslationContext (BabbageEra StandardCrypto)
alonzoGenesis (NodeConfig -> TriggerHardFork
ncAlonzoToBabbage NodeConfig
dnc))

shelleyPraosNonce :: ShelleyConfig -> Shelley.Spec.Nonce
shelleyPraosNonce :: ShelleyConfig -> Nonce
shelleyPraosNonce ShelleyConfig
sCfg = Hash Blake2b_256 Nonce -> Nonce
Shelley.Spec.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)
-> (GenesisHashShelley -> Hash Blake2b_256 ByteString)
-> GenesisHashShelley
-> Hash Blake2b_256 Nonce
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenesisHashShelley -> Hash Blake2b_256 ByteString
unGenesisHashShelley (GenesisHashShelley -> Hash Blake2b_256 Nonce)
-> GenesisHashShelley -> Hash Blake2b_256 Nonce
forall a b. (a -> b) -> a -> b
$ ShelleyConfig -> GenesisHashShelley
scGenesisHash ShelleyConfig
sCfg)

shelleyProtVer :: NodeConfig -> Shelley.Spec.ProtVer
shelleyProtVer :: NodeConfig -> ProtVer
shelleyProtVer NodeConfig
dnc =
  let bver :: ProtocolVersion
bver = NodeConfig -> ProtocolVersion
ncByronProtocolVersion NodeConfig
dnc in
  Natural -> Natural -> ProtVer
Shelley.Spec.ProtVer
    (Word16 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Natural) -> Word16 -> Natural
forall a b. (a -> b) -> a -> b
$ ProtocolVersion -> Word16
Cardano.Chain.Update.pvMajor ProtocolVersion
bver)
    (Word16 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Natural) -> Word16 -> Natural
forall a b. (a -> b) -> a -> b
$ ProtocolVersion -> Word16
Cardano.Chain.Update.pvMinor ProtocolVersion
bver)

readCardanoGenesisConfig
        :: NodeConfig
        -> ExceptT GenesisConfigError IO GenesisConfig
readCardanoGenesisConfig :: NodeConfig -> ExceptT GenesisConfigError IO GenesisConfig
readCardanoGenesisConfig NodeConfig
enc =
  NodeConfig
-> Config -> ShelleyConfig -> AlonzoGenesis -> GenesisConfig
GenesisCardano NodeConfig
enc
    (Config -> ShelleyConfig -> AlonzoGenesis -> GenesisConfig)
-> ExceptT GenesisConfigError IO Config
-> ExceptT
     GenesisConfigError
     IO
     (ShelleyConfig -> AlonzoGenesis -> GenesisConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeConfig -> ExceptT GenesisConfigError IO Config
readByronGenesisConfig NodeConfig
enc
    ExceptT
  GenesisConfigError
  IO
  (ShelleyConfig -> AlonzoGenesis -> GenesisConfig)
-> ExceptT GenesisConfigError IO ShelleyConfig
-> ExceptT GenesisConfigError IO (AlonzoGenesis -> GenesisConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NodeConfig -> ExceptT GenesisConfigError IO ShelleyConfig
readShelleyGenesisConfig NodeConfig
enc
    ExceptT GenesisConfigError IO (AlonzoGenesis -> GenesisConfig)
-> ExceptT GenesisConfigError IO AlonzoGenesis
-> ExceptT GenesisConfigError IO GenesisConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NodeConfig -> ExceptT GenesisConfigError IO AlonzoGenesis
readAlonzoGenesisConfig NodeConfig
enc

data GenesisConfigError
  = NEError !Text
  | NEByronConfig !FilePath !Cardano.Chain.Genesis.ConfigurationError
  | NEShelleyConfig !FilePath !Text
  | NEAlonzoConfig !FilePath !Text
  | NECardanoConfig !Text

renderGenesisConfigError :: GenesisConfigError -> Text
renderGenesisConfigError :: GenesisConfigError -> Text
renderGenesisConfigError GenesisConfigError
ne =
  case GenesisConfigError
ne of
    NEError Text
t -> Text
"Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t
    NEByronConfig String
fp ConfigurationError
ce ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Failed reading Byron genesis file ", String -> Text
forall a. Show a => a -> Text
textShow String
fp, Text
": ", ConfigurationError -> Text
forall a. Show a => a -> Text
textShow ConfigurationError
ce
        ]
    NEShelleyConfig String
fp Text
txt ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Failed reading Shelley genesis file ", String -> Text
forall a. Show a => a -> Text
textShow String
fp, Text
": ", Text
txt
        ]
    NEAlonzoConfig String
fp Text
txt ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Failed reading Alonzo genesis file ", String -> Text
forall a. Show a => a -> Text
textShow String
fp, Text
": ", Text
txt
        ]
    NECardanoConfig Text
err ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"With Cardano protocol, Byron/Shelley config mismatch:\n"
        , Text
"   ", Text
err
        ]

data LookupFail
  = DbLookupBlockHash !ByteString
  | DbLookupBlockId !Word64
  | DbLookupMessage !Text
  | DbLookupTxHash !ByteString
  | DbLookupTxOutPair !ByteString !Word16
  | DbLookupEpochNo !Word64
  | DbLookupSlotNo !Word64
  | DbMetaEmpty
  | DbMetaMultipleRows
  deriving (LookupFail -> LookupFail -> Bool
(LookupFail -> LookupFail -> Bool)
-> (LookupFail -> LookupFail -> Bool) -> Eq LookupFail
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LookupFail -> LookupFail -> Bool
$c/= :: LookupFail -> LookupFail -> Bool
== :: LookupFail -> LookupFail -> Bool
$c== :: LookupFail -> LookupFail -> Bool
Eq, Int -> LookupFail -> ShowS
[LookupFail] -> ShowS
LookupFail -> String
(Int -> LookupFail -> ShowS)
-> (LookupFail -> String)
-> ([LookupFail] -> ShowS)
-> Show LookupFail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LookupFail] -> ShowS
$cshowList :: [LookupFail] -> ShowS
show :: LookupFail -> String
$cshow :: LookupFail -> String
showsPrec :: Int -> LookupFail -> ShowS
$cshowsPrec :: Int -> LookupFail -> ShowS
Show)

readByronGenesisConfig
        :: NodeConfig
        -> ExceptT GenesisConfigError IO Cardano.Chain.Genesis.Config
readByronGenesisConfig :: NodeConfig -> ExceptT GenesisConfigError IO Config
readByronGenesisConfig NodeConfig
enc = do
  let file :: String
file = GenesisFile -> String
unGenesisFile (GenesisFile -> String) -> GenesisFile -> String
forall a b. (a -> b) -> a -> b
$ NodeConfig -> GenesisFile
ncByronGenesisFile NodeConfig
enc
  AbstractHash Blake2b_256 Raw
genHash <- (Text -> GenesisConfigError)
-> ExceptT Text IO (AbstractHash Blake2b_256 Raw)
-> ExceptT GenesisConfigError IO (AbstractHash Blake2b_256 Raw)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT Text -> GenesisConfigError
NEError
                (ExceptT Text IO (AbstractHash Blake2b_256 Raw)
 -> ExceptT GenesisConfigError IO (AbstractHash Blake2b_256 Raw))
-> (Either Text (AbstractHash Blake2b_256 Raw)
    -> ExceptT Text IO (AbstractHash Blake2b_256 Raw))
-> Either Text (AbstractHash Blake2b_256 Raw)
-> ExceptT GenesisConfigError IO (AbstractHash Blake2b_256 Raw)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text (AbstractHash Blake2b_256 Raw)
-> ExceptT Text IO (AbstractHash Blake2b_256 Raw)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither
                (Either Text (AbstractHash Blake2b_256 Raw)
 -> ExceptT GenesisConfigError IO (AbstractHash Blake2b_256 Raw))
-> Either Text (AbstractHash Blake2b_256 Raw)
-> ExceptT GenesisConfigError IO (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 IO Config
-> ExceptT GenesisConfigError IO Config
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT (String -> ConfigurationError -> GenesisConfigError
NEByronConfig String
file)
                (ExceptT ConfigurationError IO Config
 -> ExceptT GenesisConfigError IO Config)
-> ExceptT ConfigurationError IO Config
-> ExceptT GenesisConfigError IO Config
forall a b. (a -> b) -> a -> b
$ RequiresNetworkMagic
-> String
-> AbstractHash Blake2b_256 Raw
-> ExceptT ConfigurationError IO 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
    :: NodeConfig
    -> ExceptT GenesisConfigError IO ShelleyConfig
readShelleyGenesisConfig :: NodeConfig -> ExceptT GenesisConfigError IO ShelleyConfig
readShelleyGenesisConfig NodeConfig
enc = do
  let file :: String
file = GenesisFile -> String
unGenesisFile (GenesisFile -> String) -> GenesisFile -> String
forall a b. (a -> b) -> a -> b
$ NodeConfig -> GenesisFile
ncShelleyGenesisFile NodeConfig
enc
  (ShelleyGenesisError -> GenesisConfigError)
-> ExceptT ShelleyGenesisError IO ShelleyConfig
-> ExceptT GenesisConfigError IO ShelleyConfig
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT (String -> Text -> GenesisConfigError
NEShelleyConfig String
file (Text -> GenesisConfigError)
-> (ShelleyGenesisError -> Text)
-> ShelleyGenesisError
-> GenesisConfigError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesisError -> Text
renderShelleyGenesisError)
    (ExceptT ShelleyGenesisError IO ShelleyConfig
 -> ExceptT GenesisConfigError IO ShelleyConfig)
-> ExceptT ShelleyGenesisError IO ShelleyConfig
-> ExceptT GenesisConfigError IO ShelleyConfig
forall a b. (a -> b) -> a -> b
$ GenesisFile
-> GenesisHashShelley
-> ExceptT ShelleyGenesisError IO ShelleyConfig
readShelleyGenesis (String -> GenesisFile
GenesisFile String
file) (NodeConfig -> GenesisHashShelley
ncShelleyGenesisHash NodeConfig
enc)

readAlonzoGenesisConfig
    :: NodeConfig
    -> ExceptT GenesisConfigError IO AlonzoGenesis
readAlonzoGenesisConfig :: NodeConfig -> ExceptT GenesisConfigError IO AlonzoGenesis
readAlonzoGenesisConfig NodeConfig
enc = do
  let file :: String
file = GenesisFile -> String
unGenesisFile (GenesisFile -> String) -> GenesisFile -> String
forall a b. (a -> b) -> a -> b
$ NodeConfig -> GenesisFile
ncAlonzoGenesisFile NodeConfig
enc
  (AlonzoGenesisError -> GenesisConfigError)
-> ExceptT AlonzoGenesisError IO AlonzoGenesis
-> ExceptT GenesisConfigError IO AlonzoGenesis
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT (String -> Text -> GenesisConfigError
NEAlonzoConfig String
file (Text -> GenesisConfigError)
-> (AlonzoGenesisError -> Text)
-> AlonzoGenesisError
-> GenesisConfigError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoGenesisError -> Text
renderAlonzoGenesisError)
    (ExceptT AlonzoGenesisError IO AlonzoGenesis
 -> ExceptT GenesisConfigError IO AlonzoGenesis)
-> ExceptT AlonzoGenesisError IO AlonzoGenesis
-> ExceptT GenesisConfigError IO AlonzoGenesis
forall a b. (a -> b) -> a -> b
$ GenesisFile
-> GenesisHashAlonzo -> ExceptT AlonzoGenesisError IO AlonzoGenesis
readAlonzoGenesis (String -> GenesisFile
GenesisFile String
file) (NodeConfig -> GenesisHashAlonzo
ncAlonzoGenesisHash NodeConfig
enc)

readShelleyGenesis
    :: GenesisFile -> GenesisHashShelley
    -> ExceptT ShelleyGenesisError IO ShelleyConfig
readShelleyGenesis :: GenesisFile
-> GenesisHashShelley
-> ExceptT ShelleyGenesisError IO ShelleyConfig
readShelleyGenesis (GenesisFile String
file) GenesisHashShelley
expectedGenesisHash = do
    ByteString
content <- (IOException -> ShelleyGenesisError)
-> IO ByteString -> ExceptT ShelleyGenesisError IO 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 IO ByteString)
-> IO ByteString -> ExceptT ShelleyGenesisError IO 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 -> ExceptT ShelleyGenesisError IO ()
checkExpectedGenesisHash GenesisHashShelley
genesisHash
    ShelleyGenesis (ShelleyEra StandardCrypto)
genesis <- (String -> ShelleyGenesisError)
-> ExceptT String IO (ShelleyGenesis (ShelleyEra StandardCrypto))
-> ExceptT
     ShelleyGenesisError IO (ShelleyGenesis (ShelleyEra StandardCrypto))
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT (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)
                  (ExceptT String IO (ShelleyGenesis (ShelleyEra StandardCrypto))
 -> ExceptT
      ShelleyGenesisError
      IO
      (ShelleyGenesis (ShelleyEra StandardCrypto)))
-> (Either String (ShelleyGenesis (ShelleyEra StandardCrypto))
    -> ExceptT String IO (ShelleyGenesis (ShelleyEra StandardCrypto)))
-> Either String (ShelleyGenesis (ShelleyEra StandardCrypto))
-> ExceptT
     ShelleyGenesisError IO (ShelleyGenesis (ShelleyEra StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String (ShelleyGenesis (ShelleyEra StandardCrypto))
-> ExceptT String IO (ShelleyGenesis (ShelleyEra StandardCrypto))
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither
                  (Either String (ShelleyGenesis (ShelleyEra StandardCrypto))
 -> ExceptT
      ShelleyGenesisError
      IO
      (ShelleyGenesis (ShelleyEra StandardCrypto)))
-> Either String (ShelleyGenesis (ShelleyEra StandardCrypto))
-> ExceptT
     ShelleyGenesisError IO (ShelleyGenesis (ShelleyEra StandardCrypto))
forall a b. (a -> b) -> a -> b
$ ByteString
-> Either String (ShelleyGenesis (ShelleyEra StandardCrypto))
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict' ByteString
content
    ShelleyConfig -> ExceptT ShelleyGenesisError IO ShelleyConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShelleyConfig -> ExceptT ShelleyGenesisError IO ShelleyConfig)
-> ShelleyConfig -> ExceptT ShelleyGenesisError IO ShelleyConfig
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis (ShelleyEra StandardCrypto)
-> GenesisHashShelley -> ShelleyConfig
ShelleyConfig ShelleyGenesis (ShelleyEra StandardCrypto)
genesis GenesisHashShelley
genesisHash
  where
    checkExpectedGenesisHash :: GenesisHashShelley -> ExceptT ShelleyGenesisError IO ()
    checkExpectedGenesisHash :: GenesisHashShelley -> ExceptT ShelleyGenesisError IO ()
checkExpectedGenesisHash GenesisHashShelley
actual =
      if GenesisHashShelley
actual GenesisHashShelley -> GenesisHashShelley -> Bool
forall a. Eq a => a -> a -> Bool
/= GenesisHashShelley
expectedGenesisHash
        then ShelleyGenesisError -> ExceptT ShelleyGenesisError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
left (GenesisHashShelley -> GenesisHashShelley -> ShelleyGenesisError
ShelleyGenesisHashMismatch GenesisHashShelley
actual GenesisHashShelley
expectedGenesisHash)
        else () -> ExceptT ShelleyGenesisError IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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
showList :: [ShelleyGenesisError] -> ShowS
$cshowList :: [ShelleyGenesisError] -> ShowS
show :: ShelleyGenesisError -> String
$cshow :: ShelleyGenesisError -> String
showsPrec :: Int -> ShelleyGenesisError -> ShowS
$cshowsPrec :: Int -> ShelleyGenesisError -> ShowS
Show

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
    :: GenesisFile -> GenesisHashAlonzo
    -> ExceptT AlonzoGenesisError IO AlonzoGenesis
readAlonzoGenesis :: GenesisFile
-> GenesisHashAlonzo -> ExceptT AlonzoGenesisError IO AlonzoGenesis
readAlonzoGenesis (GenesisFile String
file) GenesisHashAlonzo
expectedGenesisHash = do
    ByteString
content <- (IOException -> AlonzoGenesisError)
-> IO ByteString -> ExceptT AlonzoGenesisError IO 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 IO ByteString)
-> IO ByteString -> ExceptT AlonzoGenesisError IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
file
    let genesisHash :: GenesisHashAlonzo
genesisHash = Hash Blake2b_256 ByteString -> GenesisHashAlonzo
GenesisHashAlonzo ((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)
    GenesisHashAlonzo -> ExceptT AlonzoGenesisError IO ()
checkExpectedGenesisHash GenesisHashAlonzo
genesisHash
    (String -> AlonzoGenesisError)
-> ExceptT String IO AlonzoGenesis
-> ExceptT AlonzoGenesisError IO AlonzoGenesis
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT (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 IO AlonzoGenesis
 -> ExceptT AlonzoGenesisError IO AlonzoGenesis)
-> (Either String AlonzoGenesis -> ExceptT String IO AlonzoGenesis)
-> Either String AlonzoGenesis
-> ExceptT AlonzoGenesisError IO AlonzoGenesis
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String AlonzoGenesis -> ExceptT String IO AlonzoGenesis
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither
                  (Either String AlonzoGenesis
 -> ExceptT AlonzoGenesisError IO AlonzoGenesis)
-> Either String AlonzoGenesis
-> ExceptT AlonzoGenesisError IO AlonzoGenesis
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String AlonzoGenesis
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict' ByteString
content
  where
    checkExpectedGenesisHash :: GenesisHashAlonzo -> ExceptT AlonzoGenesisError IO ()
    checkExpectedGenesisHash :: GenesisHashAlonzo -> ExceptT AlonzoGenesisError IO ()
checkExpectedGenesisHash GenesisHashAlonzo
actual =
      if GenesisHashAlonzo
actual GenesisHashAlonzo -> GenesisHashAlonzo -> Bool
forall a. Eq a => a -> a -> Bool
/= GenesisHashAlonzo
expectedGenesisHash
        then AlonzoGenesisError -> ExceptT AlonzoGenesisError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
left (GenesisHashAlonzo -> GenesisHashAlonzo -> AlonzoGenesisError
AlonzoGenesisHashMismatch GenesisHashAlonzo
actual GenesisHashAlonzo
expectedGenesisHash)
        else () -> ExceptT AlonzoGenesisError IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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
showList :: [AlonzoGenesisError] -> ShowS
$cshowList :: [AlonzoGenesisError] -> ShowS
show :: AlonzoGenesisError -> String
$cshow :: AlonzoGenesisError -> String
showsPrec :: Int -> AlonzoGenesisError -> ShowS
$cshowsPrec :: Int -> AlonzoGenesisError -> ShowS
Show

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
          ]

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 :: Shelley.Spec.Credential 'Shelley.Spec.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
/= :: StakeCred -> StakeCred -> Bool
$c/= :: StakeCred -> StakeCred -> Bool
== :: StakeCred -> StakeCred -> Bool
$c== :: 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
min :: StakeCred -> StakeCred -> StakeCred
$cmin :: StakeCred -> StakeCred -> StakeCred
max :: StakeCred -> StakeCred -> StakeCred
$cmax :: StakeCred -> StakeCred -> StakeCred
>= :: StakeCred -> StakeCred -> Bool
$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
compare :: StakeCred -> StakeCred -> Ordering
$ccompare :: StakeCred -> StakeCred -> Ordering
$cp1Ord :: Eq StakeCred
Ord)

data Env = Env
  { Env -> HardForkLedgerConfig (CardanoEras StandardCrypto)
envLedgerConfig :: HFC.HardForkLedgerConfig (Consensus.CardanoEras Shelley.StandardCrypto)
  , Env
-> ConsensusConfig (HardForkProtocol (CardanoEras StandardCrypto))
envProtocolConfig :: TPraos.ConsensusConfig (HFC.HardForkProtocol (Consensus.CardanoEras Shelley.StandardCrypto))
  }

envSecurityParam :: Env -> Word64
envSecurityParam :: Env -> Word64
envSecurityParam Env
env = Word64
k
  where
    Consensus.SecurityParam Word64
k
      = ConsensusConfig (HardForkProtocol (CardanoEras StandardCrypto))
-> SecurityParam
forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> SecurityParam
HFC.hardForkConsensusConfigK
      (ConsensusConfig (HardForkProtocol (CardanoEras StandardCrypto))
 -> SecurityParam)
-> ConsensusConfig (HardForkProtocol (CardanoEras StandardCrypto))
-> SecurityParam
forall a b. (a -> b) -> a -> b
$ Env
-> ConsensusConfig (HardForkProtocol (CardanoEras StandardCrypto))
envProtocolConfig 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
  ->  HFC.HardForkBlock
            (Consensus.CardanoEras Consensus.StandardCrypto)
  -> Either LedgerStateError LedgerStateEvents
applyBlock' :: Env
-> LedgerState
-> ValidationMode
-> HardForkBlock (CardanoEras StandardCrypto)
-> Either LedgerStateError (LedgerState, [LedgerEvent])
applyBlock' Env
env LedgerState
oldState ValidationMode
validationMode HardForkBlock (CardanoEras StandardCrypto)
block = do
  let config :: HardForkLedgerConfig (CardanoEras StandardCrypto)
config = Env -> HardForkLedgerConfig (CardanoEras StandardCrypto)
envLedgerConfig Env
env
      stateOld :: LedgerState (HardForkBlock (CardanoEras StandardCrypto))
stateOld = LedgerState
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
clsState LedgerState
oldState
  case ValidationMode
validationMode of
    ValidationMode
FullValidation -> HardForkLedgerConfig (CardanoEras StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> Either LedgerStateError (LedgerState, [LedgerEvent])
tickThenApply HardForkLedgerConfig (CardanoEras StandardCrypto)
config HardForkBlock (CardanoEras StandardCrypto)
block LedgerState (HardForkBlock (CardanoEras StandardCrypto))
stateOld
    ValidationMode
QuickValidation -> HardForkLedgerConfig (CardanoEras StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> Either LedgerStateError (LedgerState, [LedgerEvent])
tickThenReapplyCheckHash HardForkLedgerConfig (CardanoEras StandardCrypto)
config HardForkBlock (CardanoEras StandardCrypto)
block LedgerState (HardForkBlock (CardanoEras StandardCrypto))
stateOld

applyBlockWithEvents
  :: Env
  -> LedgerState
  -> Bool
  -- ^ True to validate
  ->  HFC.HardForkBlock
            (Consensus.CardanoEras Consensus.StandardCrypto)
  -> Either LedgerStateError LedgerStateEvents
applyBlockWithEvents :: Env
-> LedgerState
-> Bool
-> HardForkBlock (CardanoEras StandardCrypto)
-> Either LedgerStateError (LedgerState, [LedgerEvent])
applyBlockWithEvents Env
env LedgerState
oldState Bool
enableValidation HardForkBlock (CardanoEras StandardCrypto)
block = do
  let config :: HardForkLedgerConfig (CardanoEras StandardCrypto)
config = Env -> HardForkLedgerConfig (CardanoEras StandardCrypto)
envLedgerConfig Env
env
      stateOld :: LedgerState (HardForkBlock (CardanoEras StandardCrypto))
stateOld = LedgerState
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
clsState LedgerState
oldState
  if Bool
enableValidation
    then HardForkLedgerConfig (CardanoEras StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> Either LedgerStateError (LedgerState, [LedgerEvent])
tickThenApply HardForkLedgerConfig (CardanoEras StandardCrypto)
config HardForkBlock (CardanoEras StandardCrypto)
block LedgerState (HardForkBlock (CardanoEras StandardCrypto))
stateOld
    else HardForkLedgerConfig (CardanoEras StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> Either LedgerStateError (LedgerState, [LedgerEvent])
tickThenReapplyCheckHash HardForkLedgerConfig (CardanoEras StandardCrypto)
config HardForkBlock (CardanoEras StandardCrypto)
block LedgerState (HardForkBlock (CardanoEras StandardCrypto))
stateOld

-- Like 'Consensus.tickThenReapply' but also checks that the previous hash from
-- the block matches the head hash of the ledger state.
tickThenReapplyCheckHash
    :: HFC.HardForkLedgerConfig
        (Consensus.CardanoEras Shelley.StandardCrypto)
    -> Consensus.CardanoBlock Consensus.StandardCrypto
    -> Shelley.LedgerState
        (HFC.HardForkBlock
            (Consensus.CardanoEras Shelley.StandardCrypto))
    -> Either LedgerStateError LedgerStateEvents
tickThenReapplyCheckHash :: HardForkLedgerConfig (CardanoEras StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> Either LedgerStateError (LedgerState, [LedgerEvent])
tickThenReapplyCheckHash HardForkLedgerConfig (CardanoEras StandardCrypto)
cfg HardForkBlock (CardanoEras StandardCrypto)
block LedgerState (HardForkBlock (CardanoEras StandardCrypto))
lsb =
  if HardForkBlock (CardanoEras StandardCrypto)
-> ChainHash (HardForkBlock (CardanoEras StandardCrypto))
forall blk. GetPrevHash blk => blk -> ChainHash blk
Consensus.blockPrevHash HardForkBlock (CardanoEras StandardCrypto)
block ChainHash (HardForkBlock (CardanoEras StandardCrypto))
-> ChainHash (HardForkBlock (CardanoEras StandardCrypto)) -> Bool
forall a. Eq a => a -> a -> Bool
== LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> ChainHash (HardForkBlock (CardanoEras StandardCrypto))
forall blk. UpdateLedger blk => LedgerState blk -> ChainHash blk
Ledger.ledgerTipHash LedgerState (HardForkBlock (CardanoEras StandardCrypto))
lsb
    then (LedgerState, [LedgerEvent])
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall a b. b -> Either a b
Right ((LedgerState, [LedgerEvent])
 -> Either LedgerStateError (LedgerState, [LedgerEvent]))
-> (LedgerResult
      (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
      (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
    -> (LedgerState, [LedgerEvent]))
-> LedgerResult
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerResult
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> (LedgerState, [LedgerEvent])
toLedgerStateEvents
          (LedgerResult
   (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
   (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
 -> Either LedgerStateError (LedgerState, [LedgerEvent]))
-> LedgerResult
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall a b. (a -> b) -> a -> b
$ LedgerConfig (HardForkBlock (CardanoEras StandardCrypto))
-> HardForkBlock (CardanoEras StandardCrypto)
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> LedgerResult
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> LedgerResult l l
Ledger.tickThenReapplyLedgerResult HardForkLedgerConfig (CardanoEras StandardCrypto)
LedgerConfig (HardForkBlock (CardanoEras StandardCrypto))
cfg HardForkBlock (CardanoEras StandardCrypto)
block LedgerState (HardForkBlock (CardanoEras StandardCrypto))
lsb
    else LedgerStateError
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall a b. a -> Either a b
Left (LedgerStateError
 -> Either LedgerStateError (LedgerState, [LedgerEvent]))
-> LedgerStateError
-> Either LedgerStateError (LedgerState, [LedgerEvent])
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)
                          (LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> WithOrigin SlotNo
forall blk.
UpdateLedger blk =>
LedgerState blk -> WithOrigin SlotNo
Ledger.ledgerTipSlot LedgerState (HardForkBlock (CardanoEras 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 (HardForkBlock (CardanoEras StandardCrypto))
-> ByteString
forall era. ChainHash (CardanoBlock era) -> ByteString
unChainHash
                      (ChainHash (HardForkBlock (CardanoEras StandardCrypto))
 -> ByteString)
-> ChainHash (HardForkBlock (CardanoEras StandardCrypto))
-> ByteString
forall a b. (a -> b) -> a -> b
$ LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> ChainHash (HardForkBlock (CardanoEras StandardCrypto))
forall blk. UpdateLedger blk => LedgerState blk -> ChainHash blk
Ledger.ledgerTipHash LedgerState (HardForkBlock (CardanoEras StandardCrypto))
lsb
                  , Text
" but block previous hash is "
                  , ByteString -> Text
forall bin. ByteArrayAccess bin => bin -> Text
renderByteArray (ChainHash (HardForkBlock (CardanoEras StandardCrypto))
-> ByteString
forall era. ChainHash (CardanoBlock era) -> ByteString
unChainHash (ChainHash (HardForkBlock (CardanoEras StandardCrypto))
 -> ByteString)
-> ChainHash (HardForkBlock (CardanoEras StandardCrypto))
-> ByteString
forall a b. (a -> b) -> a -> b
$ HardForkBlock (CardanoEras StandardCrypto)
-> ChainHash (HardForkBlock (CardanoEras StandardCrypto))
forall blk. GetPrevHash blk => blk -> ChainHash blk
Consensus.blockPrevHash HardForkBlock (CardanoEras 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 (CardanoEras StandardCrypto) -> ShortByteString
forall k (xs :: [k]). OneEraHash xs -> ShortByteString
HFC.getOneEraHash
                      (OneEraHash (CardanoEras StandardCrypto) -> ShortByteString)
-> OneEraHash (CardanoEras StandardCrypto) -> ShortByteString
forall a b. (a -> b) -> a -> b
$ HardForkBlock (CardanoEras StandardCrypto)
-> HeaderHash (HardForkBlock (CardanoEras StandardCrypto))
forall b. HasHeader b => b -> HeaderHash b
Ouroboros.Network.Block.blockHash HardForkBlock (CardanoEras 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
    :: HFC.HardForkLedgerConfig
        (Consensus.CardanoEras Shelley.StandardCrypto)
    -> Consensus.CardanoBlock Consensus.StandardCrypto
    -> Shelley.LedgerState
        (HFC.HardForkBlock
            (Consensus.CardanoEras Shelley.StandardCrypto))
    -> Either LedgerStateError LedgerStateEvents
tickThenApply :: HardForkLedgerConfig (CardanoEras StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> Either LedgerStateError (LedgerState, [LedgerEvent])
tickThenApply HardForkLedgerConfig (CardanoEras StandardCrypto)
cfg HardForkBlock (CardanoEras StandardCrypto)
block LedgerState (HardForkBlock (CardanoEras StandardCrypto))
lsb
  = (HardForkLedgerError (CardanoEras StandardCrypto)
 -> Either LedgerStateError (LedgerState, [LedgerEvent]))
-> (LedgerResult
      (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
      (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
    -> Either LedgerStateError (LedgerState, [LedgerEvent]))
-> Either
     (HardForkLedgerError (CardanoEras StandardCrypto))
     (LedgerResult
        (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
        (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (LedgerStateError
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall a b. a -> Either a b
Left (LedgerStateError
 -> Either LedgerStateError (LedgerState, [LedgerEvent]))
-> (HardForkLedgerError (CardanoEras StandardCrypto)
    -> LedgerStateError)
-> HardForkLedgerError (CardanoEras StandardCrypto)
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkLedgerError (CardanoEras StandardCrypto)
-> LedgerStateError
ApplyBlockError) ((LedgerState, [LedgerEvent])
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall a b. b -> Either a b
Right ((LedgerState, [LedgerEvent])
 -> Either LedgerStateError (LedgerState, [LedgerEvent]))
-> (LedgerResult
      (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
      (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
    -> (LedgerState, [LedgerEvent]))
-> LedgerResult
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerResult
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> (LedgerState, [LedgerEvent])
toLedgerStateEvents)
  (Either
   (HardForkLedgerError (CardanoEras StandardCrypto))
   (LedgerResult
      (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
      (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
 -> Either LedgerStateError (LedgerState, [LedgerEvent]))
-> Either
     (HardForkLedgerError (CardanoEras StandardCrypto))
     (LedgerResult
        (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
        (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
-> Either LedgerStateError (LedgerState, [LedgerEvent])
forall a b. (a -> b) -> a -> b
$ Except
  (HardForkLedgerError (CardanoEras StandardCrypto))
  (LedgerResult
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
-> Either
     (HardForkLedgerError (CardanoEras StandardCrypto))
     (LedgerResult
        (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
        (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
forall e a. Except e a -> Either e a
runExcept
  (Except
   (HardForkLedgerError (CardanoEras StandardCrypto))
   (LedgerResult
      (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
      (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
 -> Either
      (HardForkLedgerError (CardanoEras StandardCrypto))
      (LedgerResult
         (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
         (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))))
-> Except
     (HardForkLedgerError (CardanoEras StandardCrypto))
     (LedgerResult
        (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
        (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
-> Either
     (HardForkLedgerError (CardanoEras StandardCrypto))
     (LedgerResult
        (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
        (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
forall a b. (a -> b) -> a -> b
$ LedgerConfig (HardForkBlock (CardanoEras StandardCrypto))
-> HardForkBlock (CardanoEras StandardCrypto)
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> Except
     (LedgerErr
        (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
     (LedgerResult
        (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
        (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) (LedgerResult l l)
Ledger.tickThenApplyLedgerResult HardForkLedgerConfig (CardanoEras StandardCrypto)
LedgerConfig (HardForkBlock (CardanoEras StandardCrypto))
cfg HardForkBlock (CardanoEras StandardCrypto)
block LedgerState (HardForkBlock (CardanoEras StandardCrypto))
lsb

renderByteArray :: ByteArrayAccess bin => bin -> Text
renderByteArray :: 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 :: 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 OneEraHash (ByronBlock : CardanoShelleyEras era)
HeaderHash (CardanoBlock era)
bh)

data LeadershipError = LeaderErrDecodeLedgerStateFailure
                     | LeaderErrDecodeProtocolStateFailure (LB.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
showList :: [LeadershipError] -> ShowS
$cshowList :: [LeadershipError] -> ShowS
show :: LeadershipError -> String
$cshow :: LeadershipError -> String
showsPrec :: Int -> LeadershipError -> ShowS
$cshowsPrec :: Int -> LeadershipError -> ShowS
Show

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

nextEpochEligibleLeadershipSlots
  :: forall era.
     HasField "_d" (Core.PParams (ShelleyLedgerEra era)) UnitInterval
  => Ledger.Era (ShelleyLedgerEra era)
  => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Spec.Credential 'Shelley.Spec.Staking (Cardano.Ledger.Era.Crypto (ShelleyLedgerEra era)))
  => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era))
  => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era)
  => ShelleyBasedEra era
  -> ShelleyGenesis Shelley.StandardShelley
  -> 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
  -> ProtocolParameters
  -> EpochInfo (Either Text)
  -> (ChainTip, EpochNo)
  -> Either LeadershipError (Set SlotNo)
nextEpochEligibleLeadershipSlots :: ShelleyBasedEra era
-> ShelleyGenesis (ShelleyEra StandardCrypto)
-> SerialisedCurrentEpochState era
-> ProtocolState era
-> PoolId
-> SigningKey VrfKey
-> ProtocolParameters
-> EpochInfo (Either Text)
-> (ChainTip, EpochNo)
-> Either LeadershipError (Set SlotNo)
nextEpochEligibleLeadershipSlots ShelleyBasedEra era
sbe ShelleyGenesis (ShelleyEra StandardCrypto)
sGen SerialisedCurrentEpochState era
serCurrEpochState ProtocolState era
ptclState PoolId
poolid (VrfSigningKey vrfSkey) ProtocolParameters
pParams EpochInfo (Either Text)
eInfo (ChainTip
cTip, EpochNo
currentEpoch) = do
  (SlotNo
_, SlotNo
currentEpochLastSlot) <- (Text -> LeadershipError)
-> Either Text (SlotNo, SlotNo)
-> Either LeadershipError (SlotNo, SlotNo)
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 (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 -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
1)


  -- First we check if we are within 3k/f slots of the end of the current epoch.
  -- 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
3 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* ShelleyGenesis (ShelleyEra StandardCrypto) -> Word64
forall era. ShelleyGenesis era -> Word64
sgSecurityParam ShelleyGenesis (ShelleyEra StandardCrypto)
sGen) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ PositiveUnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
Shelley.Spec.unboundRational (ShelleyGenesis (ShelleyEra StandardCrypto) -> PositiveUnitInterval
forall era. ShelleyGenesis era -> PositiveUnitInterval
sgActiveSlotsCoeff ShelleyGenesis (ShelleyEra StandardCrypto)
sGen)
      stabilityWindowSlots :: SlotNo
      stabilityWindowSlots :: SlotNo
stabilityWindowSlots = forall b. (Integral Word64, Num b) => Word64 -> b
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 a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Word64) -> Double -> Word64
forall a b. (a -> b) -> a -> b
$ Rational -> Double
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


  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 (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 (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 :: PraosNonces -> Nonce
candidateNonce :: Nonce
Consensus.candidateNonce, Nonce
evolvingNonce :: PraosNonces -> Nonce
evolvingNonce :: Nonce
Consensus.evolvingNonce } =
        Proxy (ConsensusProtocol era)
-> ChainDepState (ConsensusProtocol era) -> PraosNonces
forall p (proxy :: * -> *).
PraosProtocolSupportsNode p =>
proxy p -> ChainDepState p -> PraosNonces
Consensus.getPraosNonces (Proxy (ConsensusProtocol era)
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
Consensus.getPraosNonces (Proxy (ConsensusProtocol era)
forall k (t :: k). Proxy t
Proxy @(Api.ConsensusProtocol era)) ChainDepState (ConsensusProtocol era)
chainDepState)
      extraEntropy :: Nonce
extraEntropy = Maybe PraosNonce -> Nonce
toLedgerNonce (Maybe PraosNonce -> Nonce) -> Maybe PraosNonce -> Nonce
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Maybe PraosNonce
protocolParamExtraPraosEntropy ProtocolParameters
pParams
      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 (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
-> ((FromCBOR (PParams (ShelleyLedgerEra era)),
     FromCBOR (State (EraRule "PPUP" (ShelleyLedgerEra era))),
     FromCBOR (Value (ShelleyLedgerEra era)),
     FromSharedCBOR (TxOut (ShelleyLedgerEra era))) =>
    Either DecoderError (CurrentEpochState era))
-> Either DecoderError (CurrentEpochState era)
forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> ((FromCBOR (PParams ledgerera),
     FromCBOR (State (EraRule "PPUP" ledgerera)),
     FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
    a)
-> a
obtainDecodeEpochStateConstraints ShelleyBasedEra era
sbe
                                 (((FromCBOR (PParams (ShelleyLedgerEra era)),
   FromCBOR (State (EraRule "PPUP" (ShelleyLedgerEra era))),
   FromCBOR (Value (ShelleyLedgerEra era)),
   FromSharedCBOR (TxOut (ShelleyLedgerEra era))) =>
  Either DecoderError (CurrentEpochState era))
 -> Either DecoderError (CurrentEpochState era))
-> ((FromCBOR (PParams (ShelleyLedgerEra era)),
     FromCBOR (State (EraRule "PPUP" (ShelleyLedgerEra era))),
     FromCBOR (Value (ShelleyLedgerEra era)),
     FromSharedCBOR (TxOut (ShelleyLedgerEra era))) =>
    Either DecoderError (CurrentEpochState era))
-> Either DecoderError (CurrentEpochState era)
forall a b. (a -> b) -> a -> b
$ SerialisedCurrentEpochState era
-> Either DecoderError (CurrentEpochState era)
forall era.
(Era (ShelleyLedgerEra era),
 Share (TxOut (ShelleyLedgerEra era))
 ~ Interns (Credential 'Staking (Crypto (ShelleyLedgerEra era))),
 FromSharedCBOR (TxOut (ShelleyLedgerEra era)),
 Share (TxOut (ShelleyLedgerEra era))
 ~ Interns (Credential 'Staking (Crypto (ShelleyLedgerEra era))),
 FromCBOR (PParams (ShelleyLedgerEra era)),
 FromCBOR (Value (ShelleyLedgerEra era)),
 FromCBOR (State (EraRule "PPUP" (ShelleyLedgerEra era)))) =>
SerialisedCurrentEpochState era
-> Either DecoderError (CurrentEpochState era)
decodeCurrentEpochState SerialisedCurrentEpochState era
serCurrEpochState

  let markSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto)
      markSnapshotPoolDistr :: Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
markSnapshotPoolDistr = PoolDistr StandardCrypto
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
forall crypto.
PoolDistr crypto
-> Map (KeyHash 'StakePool crypto) (IndividualPoolStake crypto)
ShelleyAPI.unPoolDistr (PoolDistr StandardCrypto
 -> Map
      (KeyHash 'StakePool StandardCrypto)
      (IndividualPoolStake StandardCrypto))
-> (SnapShots StandardCrypto -> PoolDistr StandardCrypto)
-> SnapShots StandardCrypto
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapShot StandardCrypto -> PoolDistr StandardCrypto
forall crypto. SnapShot crypto -> PoolDistr crypto
ShelleyAPI.calculatePoolDistr (SnapShot StandardCrypto -> PoolDistr StandardCrypto)
-> (SnapShots StandardCrypto -> SnapShot StandardCrypto)
-> SnapShots StandardCrypto
-> PoolDistr StandardCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapShots StandardCrypto -> SnapShot StandardCrypto
forall crypto. SnapShots crypto -> SnapShot crypto
ShelleyAPI._pstakeMark
                                (SnapShots StandardCrypto
 -> Map
      (KeyHash 'StakePool StandardCrypto)
      (IndividualPoolStake StandardCrypto))
-> SnapShots StandardCrypto
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> ((Crypto (ShelleyLedgerEra era) ~ StandardCrypto) =>
    SnapShots StandardCrypto)
-> SnapShots StandardCrypto
forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> ((Crypto ledgerera ~ StandardCrypto) => a) -> a
obtainIsStandardCrypto ShelleyBasedEra era
sbe (((Crypto (ShelleyLedgerEra era) ~ StandardCrypto) =>
  SnapShots StandardCrypto)
 -> SnapShots StandardCrypto)
-> ((Crypto (ShelleyLedgerEra era) ~ StandardCrypto) =>
    SnapShots StandardCrypto)
-> SnapShots StandardCrypto
forall a b. (a -> b) -> a -> b
$ EpochState (ShelleyLedgerEra era)
-> SnapShots (Crypto (ShelleyLedgerEra era))
forall era. EpochState era -> SnapShots (Crypto era)
ShelleyAPI.esSnapshots EpochState (ShelleyLedgerEra era)
cEstate

  let slotRangeOfInterest :: Set SlotNo
slotRangeOfInterest = (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 (ShelleyLedgerEra era) -> UnitInterval
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_d" (ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
forall era.
ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
toLedgerPParams ShelleyBasedEra era
sbe ProtocolParameters
pParams)))
        (Set SlotNo -> Set SlotNo) -> Set SlotNo -> Set SlotNo
forall a b. (a -> b) -> a -> b
$ [SlotNo] -> Set SlotNo
forall a. Ord a => [a] -> Set a
Set.fromList [SlotNo
firstSlotOfEpoch .. SlotNo
lastSlotofEpoch]

  case ShelleyBasedEra era
sbe of
    ShelleyBasedEra era
ShelleyBasedEraShelley  -> 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 Set SlotNo
slotRangeOfInterest PoolId
poolid Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
markSnapshotPoolDistr Nonce
nextEpochsNonce SignKeyVRF PraosVRF
SignKeyVRF StandardCrypto
vrfSkey ActiveSlotCoeff
f
    ShelleyBasedEra era
ShelleyBasedEraAllegra  -> 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 Set SlotNo
slotRangeOfInterest PoolId
poolid Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
markSnapshotPoolDistr Nonce
nextEpochsNonce SignKeyVRF PraosVRF
SignKeyVRF StandardCrypto
vrfSkey ActiveSlotCoeff
f
    ShelleyBasedEra era
ShelleyBasedEraMary     -> 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 Set SlotNo
slotRangeOfInterest PoolId
poolid Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
markSnapshotPoolDistr Nonce
nextEpochsNonce SignKeyVRF PraosVRF
SignKeyVRF StandardCrypto
vrfSkey ActiveSlotCoeff
f
    ShelleyBasedEra era
ShelleyBasedEraAlonzo   -> 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 Set SlotNo
slotRangeOfInterest PoolId
poolid Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
markSnapshotPoolDistr Nonce
nextEpochsNonce SignKeyVRF PraosVRF
SignKeyVRF StandardCrypto
vrfSkey ActiveSlotCoeff
f
    ShelleyBasedEra era
ShelleyBasedEraBabbage  -> 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)
markSnapshotPoolDistr Nonce
nextEpochsNonce SignKeyVRF StandardCrypto
vrfSkey ActiveSlotCoeff
f

 where
  globals :: Globals
globals = ShelleyGenesis (ShelleyEra StandardCrypto)
-> EpochInfo (Either Text) -> ProtocolParameters -> Globals
constructGlobals ShelleyGenesis (ShelleyEra StandardCrypto)
sGen EpochInfo (Either Text)
eInfo ProtocolParameters
pParams

  f :: Shelley.Spec.ActiveSlotCoeff
  f :: ActiveSlotCoeff
f = Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
globals


--getFromCbor
--  :: ShelleyBasedEra era
--  -> (( FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))
--      , FromCBOR (ChainDepStateProtocol era)
--      ) => a)
--  -> a
--getFromCbor ShelleyBasedEraShelley f = f
--getFromCbor ShelleyBasedEraAllegra f = f
--getFromCbor ShelleyBasedEraMary f = f
--getFromCbor ShelleyBasedEraAlonzo f = f
--getFromCbor ShelleyBasedEraBabbage f = f

-- | 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 Shelley.Spec.Seed
  => Crypto.VRFAlgorithm v
  => Crypto.ContextVRF v ~ ()
  => Set SlotNo
  -> PoolId
  -> Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto)
  -> Consensus.Nonce
  -> Crypto.SignKeyVRF v
  -> Shelley.Spec.ActiveSlotCoeff
  -> Either LeadershipError (Set SlotNo)
isLeadingSlotsTPraos :: 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 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 <- Either LeadershipError Rational
-> (Rational -> Either LeadershipError Rational)
-> Maybe Rational
-> Either LeadershipError Rational
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (LeadershipError -> Either LeadershipError Rational
forall a b. a -> Either a b
Left (LeadershipError -> Either LeadershipError Rational)
-> LeadershipError -> Either LeadershipError Rational
forall a b. (a -> b) -> a -> b
$ PoolId -> LeadershipError
LeaderErrStakePoolHasNoStake PoolId
poolid) Rational -> Either LeadershipError Rational
forall a b. b -> Either a b
Right (Maybe Rational -> Either LeadershipError Rational)
-> Maybe Rational -> Either LeadershipError Rational
forall a b. (a -> b) -> a -> b
$
    IndividualPoolStake StandardCrypto -> Rational
forall crypto. IndividualPoolStake crypto -> 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
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 (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 Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto)
  -> Consensus.Nonce
  -> SL.SignKeyVRF Shelley.StandardCrypto
  -> Shelley.Spec.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 poolHash = PoolId
poolid

  Rational
stakePoolStake <- Either LeadershipError Rational
-> (Rational -> Either LeadershipError Rational)
-> Maybe Rational
-> Either LeadershipError Rational
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (LeadershipError -> Either LeadershipError Rational
forall a b. a -> Either a b
Left (LeadershipError -> Either LeadershipError Rational)
-> LeadershipError -> Either LeadershipError Rational
forall a b. (a -> b) -> a -> b
$ PoolId -> LeadershipError
LeaderErrStakePoolHasNoStake PoolId
poolid) Rational -> Either LeadershipError Rational
forall a b. b -> Either a b
Right (Maybe Rational -> Either LeadershipError Rational)
-> Maybe Rational -> Either LeadershipError Rational
forall a b. (a -> b) -> a -> b
$
    IndividualPoolStake StandardCrypto -> Rational
forall crypto. IndividualPoolStake crypto -> 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 (Proxy StandardCrypto
forall k (t :: k). Proxy t
Proxy @Shelley.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

obtainIsStandardCrypto
  :: ShelleyLedgerEra era ~ ledgerera
  => ShelleyBasedEra era
  -> (Cardano.Ledger.Era.Crypto ledgerera ~ Shelley.StandardCrypto => a)
  -> a
obtainIsStandardCrypto :: ShelleyBasedEra era
-> ((Crypto ledgerera ~ StandardCrypto) => a) -> a
obtainIsStandardCrypto ShelleyBasedEra era
ShelleyBasedEraShelley (Crypto ledgerera ~ StandardCrypto) => a
f = a
(Crypto ledgerera ~ StandardCrypto) => a
f
obtainIsStandardCrypto ShelleyBasedEra era
ShelleyBasedEraAllegra (Crypto ledgerera ~ StandardCrypto) => a
f = a
(Crypto ledgerera ~ StandardCrypto) => a
f
obtainIsStandardCrypto ShelleyBasedEra era
ShelleyBasedEraMary    (Crypto ledgerera ~ StandardCrypto) => a
f = a
(Crypto ledgerera ~ StandardCrypto) => a
f
obtainIsStandardCrypto ShelleyBasedEra era
ShelleyBasedEraAlonzo  (Crypto ledgerera ~ StandardCrypto) => a
f = a
(Crypto ledgerera ~ StandardCrypto) => a
f
obtainIsStandardCrypto ShelleyBasedEra era
ShelleyBasedEraBabbage (Crypto ledgerera ~ StandardCrypto) => a
f = a
(Crypto ledgerera ~ StandardCrypto) => a
f


obtainDecodeEpochStateConstraints
  :: ShelleyLedgerEra era ~ ledgerera
  => ShelleyBasedEra era
  -> (( FromCBOR (Core.PParams ledgerera)
      , FromCBOR (State (Core.EraRule "PPUP" ledgerera))
      , FromCBOR (Core.Value ledgerera)
      , FromSharedCBOR (Core.TxOut ledgerera)
      ) => a) -> a
obtainDecodeEpochStateConstraints :: ShelleyBasedEra era
-> ((FromCBOR (PParams ledgerera),
     FromCBOR (State (EraRule "PPUP" ledgerera)),
     FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
    a)
-> a
obtainDecodeEpochStateConstraints ShelleyBasedEra era
ShelleyBasedEraShelley (FromCBOR (PParams ledgerera),
 FromCBOR (State (EraRule "PPUP" ledgerera)),
 FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
a
f = a
(FromCBOR (PParams ledgerera),
 FromCBOR (State (EraRule "PPUP" ledgerera)),
 FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
a
f
obtainDecodeEpochStateConstraints ShelleyBasedEra era
ShelleyBasedEraAllegra (FromCBOR (PParams ledgerera),
 FromCBOR (State (EraRule "PPUP" ledgerera)),
 FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
a
f = a
(FromCBOR (PParams ledgerera),
 FromCBOR (State (EraRule "PPUP" ledgerera)),
 FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
a
f
obtainDecodeEpochStateConstraints ShelleyBasedEra era
ShelleyBasedEraMary    (FromCBOR (PParams ledgerera),
 FromCBOR (State (EraRule "PPUP" ledgerera)),
 FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
a
f = a
(FromCBOR (PParams ledgerera),
 FromCBOR (State (EraRule "PPUP" ledgerera)),
 FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
a
f
obtainDecodeEpochStateConstraints ShelleyBasedEra era
ShelleyBasedEraAlonzo  (FromCBOR (PParams ledgerera),
 FromCBOR (State (EraRule "PPUP" ledgerera)),
 FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
a
f = a
(FromCBOR (PParams ledgerera),
 FromCBOR (State (EraRule "PPUP" ledgerera)),
 FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
a
f
obtainDecodeEpochStateConstraints ShelleyBasedEra era
ShelleyBasedEraBabbage (FromCBOR (PParams ledgerera),
 FromCBOR (State (EraRule "PPUP" ledgerera)),
 FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
a
f = a
(FromCBOR (PParams ledgerera),
 FromCBOR (State (EraRule "PPUP" ledgerera)),
 FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
a
f

-- | Return the slots at which a particular stake pool operator is
-- expected to mint a block.
currentEpochEligibleLeadershipSlots :: forall era ledgerera. ()
  => ShelleyLedgerEra era ~ ledgerera
  => Ledger.Era ledgerera
  => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era)
  => HasField "_d" (Core.PParams ledgerera) UnitInterval
  -- => Crypto.Signable (Crypto.VRF (Ledger.Crypto ledgerera)) Shelley.Spec.Seed
  => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Spec.Credential 'Shelley.Spec.Staking (Cardano.Ledger.Era.Crypto (ShelleyLedgerEra era)))
 -- => Ledger.Crypto ledgerera ~ Shelley.StandardCrypto
  => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era))
  -- => Consensus.ChainDepState (ConsensusProtocol era) ~ Consensus.ChainDepState (ConsensusProtocol era)
  => ShelleyBasedEra era
  -> ShelleyGenesis Shelley.StandardShelley
  -> EpochInfo (Either Text)
  -> ProtocolParameters
  -> ProtocolState era
  -> PoolId
  -> SigningKey VrfKey
  -> SerialisedCurrentEpochState era
  -> EpochNo -- ^ Current EpochInfo
  -> Either LeadershipError (Set SlotNo)
currentEpochEligibleLeadershipSlots :: ShelleyBasedEra era
-> ShelleyGenesis (ShelleyEra StandardCrypto)
-> EpochInfo (Either Text)
-> ProtocolParameters
-> ProtocolState era
-> PoolId
-> SigningKey VrfKey
-> SerialisedCurrentEpochState era
-> EpochNo
-> Either LeadershipError (Set SlotNo)
currentEpochEligibleLeadershipSlots ShelleyBasedEra era
sbe ShelleyGenesis (ShelleyEra StandardCrypto)
sGen EpochInfo (Either Text)
eInfo ProtocolParameters
pParams ProtocolState era
ptclState PoolId
poolid (VrfSigningKey vrkSkey) SerialisedCurrentEpochState era
serCurrEpochState EpochNo
currentEpoch = do

  chainDepState :: ChainDepState (Api.ConsensusProtocol era) <-
    ((ByteString, DecoderError) -> LeadershipError)
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
-> Either LeadershipError (ChainDepState (ConsensusProtocol era))
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
Consensus.getPraosNonces (Proxy (ConsensusProtocol era)
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 (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

  CurrentEpochState (cEstate :: ShelleyAPI.EpochState (ShelleyLedgerEra era)) <-
    (DecoderError -> LeadershipError)
-> Either DecoderError (CurrentEpochState era)
-> Either LeadershipError (CurrentEpochState era)
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
-> ((FromCBOR (PParams ledgerera),
     FromCBOR (State (EraRule "PPUP" ledgerera)),
     FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
    Either DecoderError (CurrentEpochState era))
-> Either DecoderError (CurrentEpochState era)
forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> ((FromCBOR (PParams ledgerera),
     FromCBOR (State (EraRule "PPUP" ledgerera)),
     FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
    a)
-> a
obtainDecodeEpochStateConstraints ShelleyBasedEra era
sbe
      (((FromCBOR (PParams ledgerera),
   FromCBOR (State (EraRule "PPUP" ledgerera)),
   FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
  Either DecoderError (CurrentEpochState era))
 -> Either DecoderError (CurrentEpochState era))
-> ((FromCBOR (PParams ledgerera),
     FromCBOR (State (EraRule "PPUP" ledgerera)),
     FromCBOR (Value ledgerera), FromSharedCBOR (TxOut ledgerera)) =>
    Either DecoderError (CurrentEpochState era))
-> Either DecoderError (CurrentEpochState era)
forall a b. (a -> b) -> a -> b
$ SerialisedCurrentEpochState era
-> Either DecoderError (CurrentEpochState era)
forall era.
(Era (ShelleyLedgerEra era),
 Share (TxOut (ShelleyLedgerEra era))
 ~ Interns (Credential 'Staking (Crypto (ShelleyLedgerEra era))),
 FromSharedCBOR (TxOut (ShelleyLedgerEra era)),
 Share (TxOut (ShelleyLedgerEra era))
 ~ Interns (Credential 'Staking (Crypto (ShelleyLedgerEra era))),
 FromCBOR (PParams (ShelleyLedgerEra era)),
 FromCBOR (Value (ShelleyLedgerEra era)),
 FromCBOR (State (EraRule "PPUP" (ShelleyLedgerEra era)))) =>
SerialisedCurrentEpochState era
-> Either DecoderError (CurrentEpochState era)
decodeCurrentEpochState SerialisedCurrentEpochState era
serCurrEpochState

  -- We need the "set" stake distribution (distribution of the previous epoch)
  -- in order to calculate the leadership schedule of the current epoch.
  let setSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto)
      setSnapshotPoolDistr :: Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
setSnapshotPoolDistr = PoolDistr StandardCrypto
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
forall crypto.
PoolDistr crypto
-> Map (KeyHash 'StakePool crypto) (IndividualPoolStake crypto)
ShelleyAPI.unPoolDistr (PoolDistr StandardCrypto
 -> Map
      (KeyHash 'StakePool StandardCrypto)
      (IndividualPoolStake StandardCrypto))
-> (SnapShots (Crypto (ShelleyLedgerEra era))
    -> PoolDistr StandardCrypto)
-> SnapShots (Crypto (ShelleyLedgerEra era))
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapShot StandardCrypto -> PoolDistr StandardCrypto
forall crypto. SnapShot crypto -> PoolDistr crypto
ShelleyAPI.calculatePoolDistr
                                (SnapShot StandardCrypto -> PoolDistr StandardCrypto)
-> (SnapShots (Crypto (ShelleyLedgerEra era))
    -> SnapShot StandardCrypto)
-> SnapShots (Crypto (ShelleyLedgerEra era))
-> PoolDistr StandardCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapShots StandardCrypto -> SnapShot StandardCrypto
forall crypto. SnapShots crypto -> SnapShot crypto
ShelleyAPI._pstakeSet (SnapShots StandardCrypto -> SnapShot StandardCrypto)
-> (SnapShots (Crypto (ShelleyLedgerEra era))
    -> SnapShots StandardCrypto)
-> SnapShots (Crypto (ShelleyLedgerEra era))
-> SnapShot StandardCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBasedEra era
-> ((Crypto ledgerera ~ StandardCrypto) =>
    SnapShots StandardCrypto)
-> SnapShots StandardCrypto
forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> ((Crypto ledgerera ~ StandardCrypto) => a) -> a
obtainIsStandardCrypto ShelleyBasedEra era
sbe
                                (SnapShots (Crypto (ShelleyLedgerEra era))
 -> Map
      (KeyHash 'StakePool StandardCrypto)
      (IndividualPoolStake StandardCrypto))
-> SnapShots (Crypto (ShelleyLedgerEra era))
-> Map
     (KeyHash 'StakePool StandardCrypto)
     (IndividualPoolStake StandardCrypto)
forall a b. (a -> b) -> a -> b
$ EpochState ledgerera -> SnapShots (Crypto ledgerera)
forall era. EpochState era -> SnapShots (Crypto era)
ShelleyAPI.esSnapshots EpochState ledgerera
EpochState (ShelleyLedgerEra era)
cEstate

  let slotRangeOfInterest :: Set SlotNo
slotRangeOfInterest = (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 -> UnitInterval
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_d" (ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
forall era.
ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
toLedgerPParams ShelleyBasedEra era
sbe ProtocolParameters
pParams)))
        (Set SlotNo -> Set SlotNo) -> Set SlotNo -> Set SlotNo
forall a b. (a -> b) -> a -> b
$ [SlotNo] -> Set SlotNo
forall a. Ord a => [a] -> Set a
Set.fromList [SlotNo
firstSlotOfEpoch .. SlotNo
lastSlotofEpoch]

  case ShelleyBasedEra era
sbe of
    ShelleyBasedEra era
ShelleyBasedEraShelley -> 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 Set SlotNo
slotRangeOfInterest PoolId
poolid Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
setSnapshotPoolDistr Nonce
epochNonce SignKeyVRF PraosVRF
SignKeyVRF StandardCrypto
vrkSkey ActiveSlotCoeff
f
    ShelleyBasedEra era
ShelleyBasedEraAllegra -> 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 Set SlotNo
slotRangeOfInterest PoolId
poolid Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
setSnapshotPoolDistr Nonce
epochNonce SignKeyVRF PraosVRF
SignKeyVRF StandardCrypto
vrkSkey ActiveSlotCoeff
f
    ShelleyBasedEra era
ShelleyBasedEraMary -> 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 Set SlotNo
slotRangeOfInterest PoolId
poolid Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
setSnapshotPoolDistr Nonce
epochNonce SignKeyVRF PraosVRF
SignKeyVRF StandardCrypto
vrkSkey ActiveSlotCoeff
f
    ShelleyBasedEra era
ShelleyBasedEraAlonzo -> 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 Set SlotNo
slotRangeOfInterest PoolId
poolid Map
  (KeyHash 'StakePool StandardCrypto)
  (IndividualPoolStake StandardCrypto)
setSnapshotPoolDistr Nonce
epochNonce SignKeyVRF PraosVRF
SignKeyVRF StandardCrypto
vrkSkey ActiveSlotCoeff
f
    ShelleyBasedEra era
ShelleyBasedEraBabbage -> 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)
setSnapshotPoolDistr Nonce
epochNonce SignKeyVRF StandardCrypto
vrkSkey ActiveSlotCoeff
f

 where
  globals :: Globals
globals = ShelleyGenesis (ShelleyEra StandardCrypto)
-> EpochInfo (Either Text) -> ProtocolParameters -> Globals
constructGlobals ShelleyGenesis (ShelleyEra StandardCrypto)
sGen EpochInfo (Either Text)
eInfo ProtocolParameters
pParams

  f :: Shelley.Spec.ActiveSlotCoeff
  f :: ActiveSlotCoeff
f = Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
globals

constructGlobals
  :: ShelleyGenesis Shelley.StandardShelley
  -> EpochInfo (Either Text)
  -> ProtocolParameters
  -> Globals
constructGlobals :: ShelleyGenesis (ShelleyEra StandardCrypto)
-> EpochInfo (Either Text) -> ProtocolParameters -> Globals
constructGlobals ShelleyGenesis (ShelleyEra StandardCrypto)
sGen EpochInfo (Either Text)
eInfo ProtocolParameters
pParams =
  let majorPParamsVer :: Natural
majorPParamsVer = (Natural, Natural) -> Natural
forall a b. (a, b) -> a
fst ((Natural, Natural) -> Natural) -> (Natural, Natural) -> Natural
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> (Natural, Natural)
protocolParamProtocolVersion ProtocolParameters
pParams
  in ShelleyGenesis (ShelleyEra StandardCrypto)
-> EpochInfo (Either Text) -> Natural -> Globals
forall era.
ShelleyGenesis era -> EpochInfo (Either Text) -> Natural -> Globals
Shelley.Spec.mkShelleyGlobals ShelleyGenesis (ShelleyEra StandardCrypto)
sGen EpochInfo (Either Text)
eInfo Natural
majorPParamsVer