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

module Bcc.Api.LedgerState
  ( -- * Initialization / Accumulation
    Env(..)
  , envSecurityParam
  , LedgerState
      ( ..
      , LedgerStateCole
      , LedgerStateSophie
      , LedgerStateEvie
      , LedgerStateJen
      )
  , initialLedgerState
  , applyBlock
  , ValidationMode(..)
  , applyBlockWithEvents

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

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

import           Prelude

import           Control.Exception
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Except.Extra
import           Data.Aeson as Aeson
import qualified Data.Aeson.Types as Data.Aeson.Types.Internal
import           Data.ByteArray (ByteArrayAccess)
import qualified Data.ByteArray
import           Data.ByteString as BS
import qualified Data.ByteString.Base16 as Base16
import           Data.ByteString.Short as BSS
import           Data.Foldable
import           Data.IORef
import           Data.SOP.Strict (NP (..))
import           Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import           Data.Word
import qualified Data.Yaml as Yaml
import           System.FilePath

import           Bcc.Api.Block
import           Bcc.Api.Eras
import           Bcc.Api.IPC (ConsensusModeParams,
                   LocalChainSyncClient (LocalChainSyncClientPipelined),
                   LocalNodeClientProtocols (..), LocalNodeClientProtocolsInMode,
                   LocalNodeConnectInfo (..), connectToLocalNode)
import           Bcc.Api.LedgerEvent (LedgerEvent, toLedgerEvent)
import           Bcc.Api.Modes (BccMode)
import           Bcc.Api.NetworkId (NetworkId (..), NetworkMagic (NetworkMagic))
import qualified Bcc.Chain.Genesis
import qualified Bcc.Chain.Update
import           Bcc.Crypto (ProtocolMagicId (unProtocolMagicId), RequiresNetworkMagic (..))
import qualified Bcc.Crypto.Hash.Blake2b
import qualified Bcc.Crypto.Hash.Class
import qualified Bcc.Crypto.Hashing
import qualified Bcc.Crypto.ProtocolMagic
import           Bcc.Ledger.Aurum.Genesis (AurumGenesis (..))
import qualified Bcc.Ledger.BaseTypes as Sophie.Spec
import qualified Bcc.Ledger.Credential as Sophie.Spec
import qualified Bcc.Ledger.Keys as Sophie.Spec
import           Bcc.Slotting.Slot (WithOrigin (At, Origin))
import qualified Bcc.Slotting.Slot as Slot
import           Network.TypedProtocol.Pipelined (Nat (..))
import qualified Shardagnostic.Consensus.Block.Abstract as Consensus
import qualified Shardagnostic.Consensus.Cole.Ledger.Block as Cole
import qualified Shardagnostic.Consensus.Bcc as Consensus
import qualified Shardagnostic.Consensus.Bcc.Block as Consensus
import qualified Shardagnostic.Consensus.Bcc.CanHardFork as Consensus
import qualified Shardagnostic.Consensus.Bcc.Node as Consensus
import qualified Shardagnostic.Consensus.Config as Consensus
import qualified Shardagnostic.Consensus.HardFork.Combinator as Consensus
import qualified Shardagnostic.Consensus.HardFork.Combinator.AcrossEras as HFC
import qualified Shardagnostic.Consensus.HardFork.Combinator.Basics as HFC
import qualified Shardagnostic.Consensus.Ledger.Abstract as Ledger
import qualified Shardagnostic.Consensus.Ledger.Extended as Ledger
import           Shardagnostic.Consensus.Ledger.Basics (LedgerResult (lrEvents), lrResult)
import qualified Shardagnostic.Consensus.Mempool.TxLimits as TxLimits
import qualified Shardagnostic.Consensus.Node.ProtocolInfo as Consensus
import qualified Shardagnostic.Consensus.Sophie.Eras as Sophie
import qualified Shardagnostic.Consensus.Sophie.Ledger.Block as Sophie
import qualified Shardagnostic.Consensus.Sophie.Ledger.Ledger as Sophie
import qualified Shardagnostic.Consensus.Sophie.Protocol as Sophie
import qualified Shardagnostic.Network.Block
import qualified Shardagnostic.Network.Protocol.ChainSync.Client as CS
import qualified Shardagnostic.Network.Protocol.ChainSync.ClientPipelined as CSP
import           Shardagnostic.Network.Protocol.ChainSync.PipelineDecision
import qualified Sophie.Spec.Ledger.Genesis as Sophie.Spec
import qualified Sophie.Spec.Ledger.PParams as Sophie.Spec
import Data.Maybe (mapMaybe)
import Shardagnostic.Consensus.TypeFamilyWrappers (WrapLedgerEvent(WrapLedgerEvent))

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

-- | Get the environment and initial ledger state.
initialLedgerState
  :: FilePath
  -- ^ Path to the bcc-node config file (e.g. <path to bcc-node project>/configuration/bcc/mainnet-config.json)
  ->  ExceptT InitialLedgerStateError IO (Env, LedgerState)
  -- ^ The environment and initial ledger state
initialLedgerState :: FilePath -> ExceptT InitialLedgerStateError IO (Env, LedgerState)
initialLedgerState FilePath
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 (FilePath -> NetworkConfigFile
NetworkConfigFile FilePath
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
readBccGenesisConfig 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 Text LedgerState
  -- ^ The new ledger state (or an error).
applyBlock :: Env
-> LedgerState
-> ValidationMode
-> Block era
-> Either Text LedgerState
applyBlock Env
env LedgerState
oldState ValidationMode
validationMode Block era
block
  = Env
-> LedgerState
-> ValidationMode
-> HardForkBlock (BccEras StandardCrypto)
-> Either Text LedgerState
applyBlock' Env
env LedgerState
oldState ValidationMode
validationMode (HardForkBlock (BccEras StandardCrypto) -> Either Text LedgerState)
-> HardForkBlock (BccEras StandardCrypto)
-> Either Text LedgerState
forall a b. (a -> b) -> a -> b
$ case Block era
block of
      ColeBlock ColeBlock
coleBlock -> ColeBlock -> HardForkBlock (BccEras StandardCrypto)
forall c. ColeBlock -> BccBlock c
Consensus.BlockCole ColeBlock
coleBlock
      SophieBlock SophieBasedEra era
blockEra SophieBlock (SophieLedgerEra era)
sophieBlock -> case SophieBasedEra era
blockEra of
        SophieBasedEra era
SophieBasedEraSophie -> SophieBlock (SophieEra StandardCrypto)
-> HardForkBlock (BccEras StandardCrypto)
forall c. SophieBlock (SophieEra c) -> BccBlock c
Consensus.BlockSophie SophieBlock (SophieEra StandardCrypto)
SophieBlock (SophieLedgerEra era)
sophieBlock
        SophieBasedEra era
SophieBasedEraEvie -> SophieBlock (EvieEra StandardCrypto)
-> HardForkBlock (BccEras StandardCrypto)
forall c. SophieBlock (EvieEra c) -> BccBlock c
Consensus.BlockEvie SophieBlock (EvieEra StandardCrypto)
SophieBlock (SophieLedgerEra era)
sophieBlock
        SophieBasedEra era
SophieBasedEraJen    -> SophieBlock (JenEra StandardCrypto)
-> HardForkBlock (BccEras StandardCrypto)
forall c. SophieBlock (JenEra c) -> BccBlock c
Consensus.BlockJen SophieBlock (JenEra StandardCrypto)
SophieBlock (SophieLedgerEra era)
sophieBlock
        SophieBasedEra era
SophieBasedEraAurum  -> SophieBlock (AurumEra StandardCrypto)
-> HardForkBlock (BccEras StandardCrypto)
forall c. SophieBlock (AurumEra c) -> BccBlock c
Consensus.BlockAurum SophieBlock (AurumEra StandardCrypto)
SophieBlock (SophieLedgerEra era)
sophieBlock

pattern LedgerStateCole
  :: Ledger.LedgerState Cole.ColeBlock
  -> LedgerState
pattern $mLedgerStateCole :: forall r.
LedgerState -> (LedgerState ColeBlock -> r) -> (Void# -> r) -> r
LedgerStateCole st <- LedgerState (Consensus.LedgerStateCole st)

pattern LedgerStateSophie
  :: Ledger.LedgerState (Sophie.SophieBlock (Sophie.SophieEra Sophie.StandardCrypto))
  -> LedgerState
pattern $mLedgerStateSophie :: forall r.
LedgerState
-> (LedgerState (SophieBlock (SophieEra StandardCrypto)) -> r)
-> (Void# -> r)
-> r
LedgerStateSophie st <- LedgerState  (Consensus.LedgerStateSophie st)

pattern LedgerStateEvie
  :: Ledger.LedgerState (Sophie.SophieBlock (Sophie.EvieEra Sophie.StandardCrypto))
  -> LedgerState
pattern $mLedgerStateEvie :: forall r.
LedgerState
-> (LedgerState (SophieBlock (EvieEra StandardCrypto)) -> r)
-> (Void# -> r)
-> r
LedgerStateEvie st <- LedgerState  (Consensus.LedgerStateEvie st)

pattern LedgerStateJen
  :: Ledger.LedgerState (Sophie.SophieBlock (Sophie.JenEra Sophie.StandardCrypto))
  -> LedgerState
pattern $mLedgerStateJen :: forall r.
LedgerState
-> (LedgerState (SophieBlock (JenEra StandardCrypto)) -> r)
-> (Void# -> r)
-> r
LedgerStateJen st <- LedgerState  (Consensus.LedgerStateJen st)

{-# COMPLETE LedgerStateCole
           , LedgerStateSophie
           , LedgerStateEvie
           , LedgerStateJen #-}

data FoldBlocksError
  = FoldBlocksInitialLedgerStateError InitialLedgerStateError
  | FoldBlocksApplyBlockError Text

renderFoldBlocksError :: FoldBlocksError -> Text
renderFoldBlocksError :: FoldBlocksError -> Text
renderFoldBlocksError FoldBlocksError
fbe = case FoldBlocksError
fbe of
  FoldBlocksInitialLedgerStateError InitialLedgerStateError
err -> InitialLedgerStateError -> Text
renderInitialLedgerStateError InitialLedgerStateError
err
  FoldBlocksApplyBlockError Text
err -> Text
"Failed when applying a block: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 bcc-node config file (e.g. <path to bcc-node project>/configuration/bcc/mainnet-config.json)
  -> ConsensusModeParams BccMode
  -- ^ This is needed for the number of slots per epoch for the Cole era (on
  -- mainnet that should be 21600).
  -> FilePath
  -- ^ Path to local bcc-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 -> BlockInMode BccMode -> 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@.
  --  * 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 :: FilePath
-> ConsensusModeParams BccMode
-> FilePath
-> ValidationMode
-> a
-> (Env -> LedgerState -> BlockInMode BccMode -> a -> IO a)
-> ExceptT FoldBlocksError IO a
foldBlocks FilePath
nodeConfigFilePath ConsensusModeParams BccMode
bccModeParams FilePath
socketPath ValidationMode
validationMode a
state0 Env -> LedgerState -> BlockInMode BccMode -> 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
                            (FilePath -> ExceptT InitialLedgerStateError IO (Env, LedgerState)
initialLedgerState FilePath
nodeConfigFilePath)

  -- Place to store the accumulated state
  -- This is a bit ugly, but easy.
  IORef (Maybe Text)
errorIORef <- IO (IORef (Maybe Text))
-> ExceptT FoldBlocksError IO (IORef (Maybe Text))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (IORef (Maybe Text))
 -> ExceptT FoldBlocksError IO (IORef (Maybe Text)))
-> IO (IORef (Maybe Text))
-> ExceptT FoldBlocksError IO (IORef (Maybe Text))
forall a b. (a -> b) -> a -> b
$ Maybe Text -> IO (IORef (Maybe Text))
forall a. a -> IO (IORef a)
newIORef Maybe Text
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
  -- bcc-ledger-specs repo.
  let coleConfig :: Config
coleConfig
        = (\(Consensus.WrapPartialLedgerConfig (Consensus.ColePartialLedgerConfig bc _) :* NP WrapPartialLedgerConfig xs
_) -> LedgerConfig ColeBlock
Config
bc)
        (NP WrapPartialLedgerConfig (BccEras StandardCrypto) -> Config)
-> (HardForkLedgerConfig (BccEras StandardCrypto)
    -> NP WrapPartialLedgerConfig (BccEras StandardCrypto))
-> HardForkLedgerConfig (BccEras StandardCrypto)
-> Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerEraLedgerConfig (BccEras StandardCrypto)
-> NP WrapPartialLedgerConfig (BccEras StandardCrypto)
forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
HFC.getPerEraLedgerConfig
        (PerEraLedgerConfig (BccEras StandardCrypto)
 -> NP WrapPartialLedgerConfig (BccEras StandardCrypto))
-> (HardForkLedgerConfig (BccEras StandardCrypto)
    -> PerEraLedgerConfig (BccEras StandardCrypto))
-> HardForkLedgerConfig (BccEras StandardCrypto)
-> NP WrapPartialLedgerConfig (BccEras StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkLedgerConfig (BccEras StandardCrypto)
-> PerEraLedgerConfig (BccEras StandardCrypto)
forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
HFC.hardForkLedgerConfigPerEra
        (HardForkLedgerConfig (BccEras StandardCrypto) -> Config)
-> HardForkLedgerConfig (BccEras StandardCrypto) -> Config
forall a b. (a -> b) -> a -> b
$ Env -> HardForkLedgerConfig (BccEras 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
Bcc.Chain.Genesis.gdProtocolMagicId
        (GenesisData -> ProtocolMagicId) -> GenesisData -> ProtocolMagicId
forall a b. (a -> b) -> a -> b
$ Config -> GenesisData
Bcc.Chain.Genesis.configGenesisData Config
coleConfig

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

  -- Connect to the node.
  let connectInfo :: LocalNodeConnectInfo BccMode
      connectInfo :: LocalNodeConnectInfo BccMode
connectInfo =
          LocalNodeConnectInfo :: forall mode.
ConsensusModeParams mode
-> NetworkId -> FilePath -> LocalNodeConnectInfo mode
LocalNodeConnectInfo {
            localConsensusModeParams :: ConsensusModeParams BccMode
localConsensusModeParams = ConsensusModeParams BccMode
bccModeParams,
            localNodeNetworkId :: NetworkId
localNodeNetworkId       = NetworkId
networkId,
            localNodeSocketPath :: FilePath
localNodeSocketPath      = FilePath
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 BccMode
-> LocalNodeClientProtocolsInMode BccMode -> IO ()
forall mode.
LocalNodeConnectInfo mode
-> LocalNodeClientProtocolsInMode mode -> IO ()
connectToLocalNode
    LocalNodeConnectInfo BccMode
connectInfo
    (IORef a
-> IORef (Maybe Text)
-> Env
-> LedgerState
-> LocalNodeClientProtocolsInMode BccMode
protocols IORef a
stateIORef IORef (Maybe Text)
errorIORef Env
env LedgerState
ledgerState)

  IO (Maybe Text) -> ExceptT FoldBlocksError IO (Maybe Text)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IORef (Maybe Text) -> IO (Maybe Text)
forall a. IORef a -> IO a
readIORef IORef (Maybe Text)
errorIORef) ExceptT FoldBlocksError IO (Maybe Text)
-> (Maybe Text -> ExceptT FoldBlocksError IO a)
-> ExceptT FoldBlocksError IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Text
err -> FoldBlocksError -> ExceptT FoldBlocksError IO a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> FoldBlocksError
FoldBlocksApplyBlockError Text
err)
    Maybe Text
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 Text) -> Env -> LedgerState -> LocalNodeClientProtocolsInMode BccMode
    protocols :: IORef a
-> IORef (Maybe Text)
-> Env
-> LedgerState
-> LocalNodeClientProtocolsInMode BccMode
protocols IORef a
stateIORef IORef (Maybe Text)
errorIORef Env
env LedgerState
ledgerState =
        LocalNodeClientProtocols :: forall block point tip tx txerr (query :: * -> *) (m :: * -> *).
LocalChainSyncClient block point tip m
-> Maybe (LocalTxSubmissionClient tx txerr m ())
-> Maybe (LocalStateQueryClient block point query m ())
-> LocalNodeClientProtocols block point tip tx txerr query m
LocalNodeClientProtocols {
          localChainSyncClient :: LocalChainSyncClient (BlockInMode BccMode) ChainPoint ChainTip IO
localChainSyncClient    = ChainSyncClientPipelined
  (BlockInMode BccMode) ChainPoint ChainTip IO ()
-> LocalChainSyncClient
     (BlockInMode BccMode) ChainPoint ChainTip IO
forall block point tip (m :: * -> *).
ChainSyncClientPipelined block point tip m ()
-> LocalChainSyncClient block point tip m
LocalChainSyncClientPipelined (Word32
-> IORef a
-> IORef (Maybe Text)
-> Env
-> LedgerState
-> ChainSyncClientPipelined
     (BlockInMode BccMode) ChainPoint ChainTip IO ()
chainSyncClient Word32
50 IORef a
stateIORef IORef (Maybe Text)
errorIORef Env
env LedgerState
ledgerState),
          localTxSubmissionClient :: Maybe
  (LocalTxSubmissionClient
     (TxInMode BccMode) (TxValidationErrorInMode BccMode) IO ())
localTxSubmissionClient = Maybe
  (LocalTxSubmissionClient
     (TxInMode BccMode) (TxValidationErrorInMode BccMode) IO ())
forall a. Maybe a
Nothing,
          localStateQueryClient :: Maybe
  (LocalStateQueryClient
     (BlockInMode BccMode) ChainPoint (QueryInMode BccMode) IO ())
localStateQueryClient   = Maybe
  (LocalStateQueryClient
     (BlockInMode BccMode) ChainPoint (QueryInMode BccMode) 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 Text)
                    -- ^ Resulting error if any. Written to once on protocol
                    -- completion.
                    -> Env
                    -> LedgerState
                    -> CSP.ChainSyncClientPipelined
                        (BlockInMode BccMode)
                        ChainPoint
                        ChainTip
                        IO ()
                    -- ^ Client returns maybe an error.
    chainSyncClient :: Word32
-> IORef a
-> IORef (Maybe Text)
-> Env
-> LedgerState
-> ChainSyncClientPipelined
     (BlockInMode BccMode) ChainPoint ChainTip IO ()
chainSyncClient Word32
pipelineSize IORef a
stateIORef IORef (Maybe Text)
errorIORef Env
env LedgerState
ledgerState0
      = IO
  (ClientPipelinedStIdle
     'Z (BlockInMode BccMode) ChainPoint ChainTip IO ())
-> ChainSyncClientPipelined
     (BlockInMode BccMode) 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 BccMode) ChainPoint ChainTip IO ())
 -> ChainSyncClientPipelined
      (BlockInMode BccMode) ChainPoint ChainTip IO ())
-> IO
     (ClientPipelinedStIdle
        'Z (BlockInMode BccMode) ChainPoint ChainTip IO ())
-> ChainSyncClientPipelined
     (BlockInMode BccMode) ChainPoint ChainTip IO ()
forall a b. (a -> b) -> a -> b
$ ClientPipelinedStIdle
  'Z (BlockInMode BccMode) ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle
        'Z (BlockInMode BccMode) ChainPoint ChainTip IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientPipelinedStIdle
   'Z (BlockInMode BccMode) ChainPoint ChainTip IO ()
 -> IO
      (ClientPipelinedStIdle
         'Z (BlockInMode BccMode) ChainPoint ChainTip IO ()))
-> ClientPipelinedStIdle
     'Z (BlockInMode BccMode) ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle
        'Z (BlockInMode BccMode) ChainPoint ChainTip IO ())
forall a b. (a -> b) -> a -> b
$ WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat 'Z
-> LedgerStateHistory
-> ClientPipelinedStIdle
     'Z (BlockInMode BccMode) ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) 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, WithOrigin (BlockInMode BccMode))
-> LedgerStateHistory
forall a. a -> Seq a
Seq.singleton (SlotNo
0, LedgerState
ledgerState0, WithOrigin (BlockInMode BccMode)
forall t. WithOrigin t
Origin)

          clientIdle_RequestMoreN
            :: WithOrigin BlockNo
            -> WithOrigin BlockNo
            -> Nat n -- Number of requests inflight.
            -> LedgerStateHistory
            -> CSP.ClientPipelinedStIdle n (BlockInMode BccMode) ChainPoint ChainTip IO ()
          clientIdle_RequestMoreN :: WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) 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 BccMode) ChainPoint ChainTip IO ()))
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip IO ()
-> ClientPipelinedStIdle
     ('S n) (BlockInMode BccMode) 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 BccMode) ChainPoint ChainTip IO ()))
forall a. Maybe a
Nothing (Nat n
-> LedgerStateHistory
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip IO ()
forall (n :: N).
Nat n
-> LedgerStateHistory
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip IO ()
clientNextN Nat n
predN LedgerStateHistory
knownLedgerStates)
                PipelineDecision n
_ -> ClientPipelinedStIdle
  ('S n) (BlockInMode BccMode) ChainPoint ChainTip IO ()
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) 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 BccMode) ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) 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 BccMode) ChainPoint ChainTip IO ()
          clientNextN :: Nat n
-> LedgerStateHistory
-> ClientStNext n (BlockInMode BccMode) 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 BccMode
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip IO ())
CSP.recvMsgRollForward = \blockInMode :: BlockInMode BccMode
blockInMode@(BlockInMode block :: Block era
block@(Block (BlockHeader SlotNo
slotNo Hash BlockHeader
_ BlockNo
currBlockNo) [Tx era]
_) EraInMode era BccMode
_era) ChainTip
serverChainTip -> do
                  let newLedgerStateE :: Either Text LedgerState
newLedgerStateE = Env
-> LedgerState
-> ValidationMode
-> Block era
-> Either Text LedgerState
forall era.
Env
-> LedgerState
-> ValidationMode
-> Block era
-> Either Text LedgerState
applyBlock
                        Env
env
                        (LedgerState
-> ((SlotNo, LedgerState, WithOrigin (BlockInMode BccMode))
    -> LedgerState)
-> Maybe (SlotNo, LedgerState, WithOrigin (BlockInMode BccMode))
-> LedgerState
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                          (FilePath -> LedgerState
forall a. HasCallStack => FilePath -> a
error FilePath
"Impossible! Missing Ledger state")
                          (\(SlotNo
_,LedgerState
x,WithOrigin (BlockInMode BccMode)
_) -> LedgerState
x)
                          (Int
-> LedgerStateHistory
-> Maybe (SlotNo, LedgerState, WithOrigin (BlockInMode BccMode))
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
0 LedgerStateHistory
knownLedgerStates)
                        )
                        ValidationMode
validationMode
                        Block era
block
                  case Either Text LedgerState
newLedgerStateE of
                    Left Text
err -> Nat n
-> Maybe Text
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe Text
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
err)
                    Right LedgerState
newLedgerState -> do
                      let (LedgerStateHistory
knownLedgerStates', LedgerStateHistory
committedStates) = Env
-> LedgerStateHistory
-> SlotNo
-> LedgerState
-> BlockInMode BccMode
-> (LedgerStateHistory, LedgerStateHistory)
forall a.
Env
-> History a
-> SlotNo
-> a
-> BlockInMode BccMode
-> (History a, History a)
pushLedgerState Env
env LedgerStateHistory
knownLedgerStates SlotNo
slotNo LedgerState
newLedgerState BlockInMode BccMode
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, WithOrigin (BlockInMode BccMode))
    -> IO ())
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ LedgerStateHistory
committedStates (((SlotNo, LedgerState, WithOrigin (BlockInMode BccMode)) -> IO ())
 -> IO ())
-> ((SlotNo, LedgerState, WithOrigin (BlockInMode BccMode))
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(SlotNo
_, LedgerState
currLedgerState, WithOrigin (BlockInMode BccMode)
currBlockMay) -> case WithOrigin (BlockInMode BccMode)
currBlockMay of
                          WithOrigin (BlockInMode BccMode)
Origin -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                          At BlockInMode BccMode
currBlock -> do
                            a
newState <- Env -> LedgerState -> BlockInMode BccMode -> a -> IO a
accumulate Env
env LedgerState
currLedgerState BlockInMode BccMode
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 Text
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe Text
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n Maybe Text
forall a. Maybe a
Nothing
                        else ClientPipelinedStIdle
  n (BlockInMode BccMode) ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
newClientTip WithOrigin BlockNo
newServerTip Nat n
n LedgerStateHistory
knownLedgerStates')
              , recvMsgRollBackward :: ChainPoint
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) 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 BccMode) ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) 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 Text -- Return value (maybe an error)
            -> IO (CSP.ClientPipelinedStIdle n (BlockInMode BccMode) ChainPoint ChainTip IO ())
          clientIdle_DoneN :: Nat n
-> Maybe Text
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n Maybe Text
errorMay = case Nat n
n of
            Succ Nat n
predN -> ClientPipelinedStIdle
  ('S n) (BlockInMode BccMode) ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle
        ('S n) (BlockInMode BccMode) ChainPoint ChainTip IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
  (IO
     (ClientPipelinedStIdle
        ('S n) (BlockInMode BccMode) ChainPoint ChainTip IO ()))
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip IO ()
-> ClientPipelinedStIdle
     ('S n) (BlockInMode BccMode) 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 BccMode) ChainPoint ChainTip IO ()))
forall a. Maybe a
Nothing (Nat n
-> Maybe Text
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip IO ()
forall (n :: N).
Nat n
-> Maybe Text
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip IO ()
clientNext_DoneN Nat n
predN Maybe Text
errorMay)) -- Ignore remaining message responses
            Nat n
Zero -> do
              IORef (Maybe Text) -> Maybe Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Text)
errorIORef Maybe Text
errorMay
              ClientPipelinedStIdle
  'Z (BlockInMode BccMode) ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle
        'Z (BlockInMode BccMode) ChainPoint ChainTip IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (()
-> ClientPipelinedStIdle
     'Z (BlockInMode BccMode) 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 Text -- Return value (maybe an error)
            -> CSP.ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip IO ()
          clientNext_DoneN :: Nat n
-> Maybe Text
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip IO ()
clientNext_DoneN Nat n
n Maybe Text
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 BccMode
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip IO ())
CSP.recvMsgRollForward = \BlockInMode BccMode
_ ChainTip
_ -> Nat n
-> Maybe Text
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe Text
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n Maybe Text
errorMay
              , recvMsgRollBackward :: ChainPoint
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip IO ())
CSP.recvMsgRollBackward = \ChainPoint
_ ChainTip
_ -> Nat n
-> Maybe Text
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe Text
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n Maybe Text
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 BccMode, Either Text LedgerState)
                        ChainPoint
                        ChainTip
                        m
                        a
  -- ^ A client to wrap. The block is annotated with a 'Either Text
  -- 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 BccMode)
                        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 BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ChainSyncClient (BlockInMode BccMode) ChainPoint ChainTip m a
chainSyncClientWithLedgerState Env
env LedgerState
ledgerState0 ValidationMode
validationMode (CS.ChainSyncClient m (ClientStIdle
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a)
clientTop)
  = m (ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a)
-> ChainSyncClient (BlockInMode BccMode) 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 (History (Either Text LedgerState)
-> ClientStIdle
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a
goClientStIdle History (Either Text LedgerState)
initialLedgerStateHistory (ClientStIdle
   (BlockInMode BccMode, Either Text LedgerState)
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientStIdle
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a)
clientTop)
  where
    goClientStIdle
      :: History (Either Text LedgerState)
      -> CS.ClientStIdle (BlockInMode BccMode, Either Text LedgerState) ChainPoint ChainTip m a
      -> CS.ClientStIdle (BlockInMode BccMode                         ) ChainPoint ChainTip m a
    goClientStIdle :: History (Either Text LedgerState)
-> ClientStIdle
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a
goClientStIdle History (Either Text LedgerState)
history ClientStIdle
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
client = case ClientStIdle
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
client of
      CS.SendMsgRequestNext ClientStNext
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
a m (ClientStNext
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a)
b -> ClientStNext (BlockInMode BccMode) ChainPoint ChainTip m a
-> m (ClientStNext (BlockInMode BccMode) ChainPoint ChainTip m a)
-> ClientStIdle (BlockInMode BccMode) 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 (History (Either Text LedgerState)
-> ClientStNext
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext (BlockInMode BccMode) ChainPoint ChainTip m a
goClientStNext History (Either Text LedgerState)
history ClientStNext
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
a) (History (Either Text LedgerState)
-> ClientStNext
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext (BlockInMode BccMode) ChainPoint ChainTip m a
goClientStNext History (Either Text LedgerState)
history (ClientStNext
   (BlockInMode BccMode, Either Text LedgerState)
   ChainPoint
   ChainTip
   m
   a
 -> ClientStNext (BlockInMode BccMode) ChainPoint ChainTip m a)
-> m (ClientStNext
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStNext (BlockInMode BccMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientStNext
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a)
b)
      CS.SendMsgFindIntersect [ChainPoint]
ps ClientStIntersect
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
a -> [ChainPoint]
-> ClientStIntersect (BlockInMode BccMode) ChainPoint ChainTip m a
-> ClientStIdle (BlockInMode BccMode) 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 (History (Either Text LedgerState)
-> ClientStIntersect
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIntersect (BlockInMode BccMode) ChainPoint ChainTip m a
goClientStIntersect History (Either Text LedgerState)
history ClientStIntersect
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
a)
      CS.SendMsgDone a
a -> a -> ClientStIdle (BlockInMode BccMode) 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
      :: History (Either Text LedgerState)
      -> CS.ClientStNext (BlockInMode BccMode, Either Text LedgerState) ChainPoint ChainTip m a
      -> CS.ClientStNext (BlockInMode BccMode                         ) ChainPoint ChainTip m a
    goClientStNext :: History (Either Text LedgerState)
-> ClientStNext
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext (BlockInMode BccMode) ChainPoint ChainTip m a
goClientStNext History (Either Text LedgerState)
history (CS.ClientStNext (BlockInMode BccMode, Either Text LedgerState)
-> ChainTip
-> ChainSyncClient
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
recvMsgRollForward ChainPoint
-> ChainTip
-> ChainSyncClient
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
recvMsgRollBackward) = (BlockInMode BccMode
 -> ChainTip
 -> ChainSyncClient (BlockInMode BccMode) ChainPoint ChainTip m a)
-> (ChainPoint
    -> ChainTip
    -> ChainSyncClient (BlockInMode BccMode) ChainPoint ChainTip m a)
-> ClientStNext (BlockInMode BccMode) 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 BccMode
blkInMode@(BlockInMode blk :: Block era
blk@(Block (BlockHeader SlotNo
slotNo Hash BlockHeader
_ BlockNo
_) [Tx era]
_) EraInMode era BccMode
_) ChainTip
tip -> m (ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a)
-> ChainSyncClient (BlockInMode BccMode) 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 BccMode) ChainPoint ChainTip m a)
 -> ChainSyncClient (BlockInMode BccMode) ChainPoint ChainTip m a)
-> m (ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a)
-> ChainSyncClient (BlockInMode BccMode) ChainPoint ChainTip m a
forall a b. (a -> b) -> a -> b
$ let
          newLedgerStateE :: Either Text LedgerState
newLedgerStateE = case Int
-> History (Either Text LedgerState)
-> Maybe
     (SlotNo, Either Text LedgerState, WithOrigin (BlockInMode BccMode))
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
0 History (Either Text LedgerState)
history of
            Maybe
  (SlotNo, Either Text LedgerState, WithOrigin (BlockInMode BccMode))
Nothing -> Text -> Either Text LedgerState
forall a b. a -> Either a b
Left Text
"Rolled back too far."
            Just (SlotNo
_, Left Text
err, WithOrigin (BlockInMode BccMode)
_) -> Text -> Either Text LedgerState
forall a b. a -> Either a b
Left Text
err
            Just (SlotNo
_, Right LedgerState
oldLedgerState, WithOrigin (BlockInMode BccMode)
_) -> Env
-> LedgerState
-> ValidationMode
-> Block era
-> Either Text LedgerState
forall era.
Env
-> LedgerState
-> ValidationMode
-> Block era
-> Either Text LedgerState
applyBlock
                  Env
env
                  LedgerState
oldLedgerState
                  ValidationMode
validationMode
                  Block era
blk
          (History (Either Text LedgerState)
history', History (Either Text LedgerState)
_) = Env
-> History (Either Text LedgerState)
-> SlotNo
-> Either Text LedgerState
-> BlockInMode BccMode
-> (History (Either Text LedgerState),
    History (Either Text LedgerState))
forall a.
Env
-> History a
-> SlotNo
-> a
-> BlockInMode BccMode
-> (History a, History a)
pushLedgerState Env
env History (Either Text LedgerState)
history SlotNo
slotNo Either Text LedgerState
newLedgerStateE BlockInMode BccMode
blkInMode
          in History (Either Text LedgerState)
-> ClientStIdle
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a
goClientStIdle History (Either Text LedgerState)
history' (ClientStIdle
   (BlockInMode BccMode, Either Text LedgerState)
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClient
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
-> m (ClientStIdle
        (BlockInMode BccMode, Either Text LedgerState)
        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 BccMode, Either Text LedgerState)
-> ChainTip
-> ChainSyncClient
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
recvMsgRollForward (BlockInMode BccMode
blkInMode, Either Text LedgerState
newLedgerStateE) ChainTip
tip)
      )
      (\ChainPoint
point ChainTip
tip -> let
              history' :: History (Either Text LedgerState)
history' = case ChainPoint
point of
                            ChainPoint
ChainPointAtGenesis -> History (Either Text LedgerState)
initialLedgerStateHistory
                            ChainPoint SlotNo
slotNo Hash BlockHeader
_ -> History (Either Text LedgerState)
-> SlotNo -> History (Either Text LedgerState)
forall a. History a -> SlotNo -> History a
rollBackLedgerStateHist History (Either Text LedgerState)
history SlotNo
slotNo
            in m (ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a)
-> ChainSyncClient (BlockInMode BccMode) 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 BccMode) ChainPoint ChainTip m a)
 -> ChainSyncClient (BlockInMode BccMode) ChainPoint ChainTip m a)
-> m (ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a)
-> ChainSyncClient (BlockInMode BccMode) ChainPoint ChainTip m a
forall a b. (a -> b) -> a -> b
$ History (Either Text LedgerState)
-> ClientStIdle
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a
goClientStIdle History (Either Text LedgerState)
history' (ClientStIdle
   (BlockInMode BccMode, Either Text LedgerState)
   ChainPoint
   ChainTip
   m
   a
 -> ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a)
-> m (ClientStIdle
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStIdle (BlockInMode BccMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainSyncClient
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
-> m (ClientStIdle
        (BlockInMode BccMode, Either Text LedgerState)
        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 BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
recvMsgRollBackward ChainPoint
point ChainTip
tip)
      )

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

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

-- | See 'chainSyncClientWithLedgerState'.
chainSyncClientPipelinedWithLedgerState
  :: forall m a.
     Monad m
  => Env
  -> LedgerState
  -> ValidationMode
  -> CSP.ChainSyncClientPipelined
                        (BlockInMode BccMode, Either Text LedgerState)
                        ChainPoint
                        ChainTip
                        m
                        a
  -> CSP.ChainSyncClientPipelined
                        (BlockInMode BccMode)
                        ChainPoint
                        ChainTip
                        m
                        a
chainSyncClientPipelinedWithLedgerState :: Env
-> LedgerState
-> ValidationMode
-> ChainSyncClientPipelined
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ChainSyncClientPipelined
     (BlockInMode BccMode) ChainPoint ChainTip m a
chainSyncClientPipelinedWithLedgerState Env
env LedgerState
ledgerState0 ValidationMode
validationMode (CSP.ChainSyncClientPipelined m (ClientPipelinedStIdle
     'Z
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a)
clientTop)
  = m (ClientPipelinedStIdle
     'Z (BlockInMode BccMode) ChainPoint ChainTip m a)
-> ChainSyncClientPipelined
     (BlockInMode BccMode) 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 (History (Either Text LedgerState)
-> Nat 'Z
-> ClientPipelinedStIdle
     'Z
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     'Z (BlockInMode BccMode) ChainPoint ChainTip m a
forall (n :: N).
History (Either Text LedgerState)
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) ChainPoint ChainTip m a
goClientPipelinedStIdle History (Either Text LedgerState)
initialLedgerStateHistory Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero (ClientPipelinedStIdle
   'Z
   (BlockInMode BccMode, Either Text LedgerState)
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle
      'Z (BlockInMode BccMode) ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        'Z
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle
        'Z (BlockInMode BccMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientPipelinedStIdle
     'Z
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a)
clientTop)
  where
    goClientPipelinedStIdle
      :: History (Either Text LedgerState)
      -> Nat n
      -> CSP.ClientPipelinedStIdle n (BlockInMode BccMode, Either Text LedgerState) ChainPoint ChainTip m a
      -> CSP.ClientPipelinedStIdle n (BlockInMode BccMode                           ) ChainPoint ChainTip m a
    goClientPipelinedStIdle :: History (Either Text LedgerState)
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) ChainPoint ChainTip m a
goClientPipelinedStIdle History (Either Text LedgerState)
history Nat n
n ClientPipelinedStIdle
  n
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
client = case ClientPipelinedStIdle
  n
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
client of
      CSP.SendMsgRequestNext ClientStNext
  'Z
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
a m (ClientStNext
     'Z
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a)
b -> ClientStNext 'Z (BlockInMode BccMode) ChainPoint ChainTip m a
-> m (ClientStNext
        'Z (BlockInMode BccMode) ChainPoint ChainTip m a)
-> ClientPipelinedStIdle
     'Z (BlockInMode BccMode) 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 (History (Either Text LedgerState)
-> Nat n
-> ClientStNext
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip m a
forall (n :: N).
History (Either Text LedgerState)
-> Nat n
-> ClientStNext
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip m a
goClientStNext History (Either Text LedgerState)
history Nat n
n ClientStNext
  n
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
ClientStNext
  'Z
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
a) (History (Either Text LedgerState)
-> Nat n
-> ClientStNext
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip m a
forall (n :: N).
History (Either Text LedgerState)
-> Nat n
-> ClientStNext
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip m a
goClientStNext History (Either Text LedgerState)
history Nat n
n (ClientStNext
   n
   (BlockInMode BccMode, Either Text LedgerState)
   ChainPoint
   ChainTip
   m
   a
 -> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip m a)
-> m (ClientStNext
        n
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ClientStNext
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a)
m (ClientStNext
     'Z
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a)
b)
      CSP.SendMsgRequestNextPipelined ClientPipelinedStIdle
  ('S n)
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
a ->  ClientPipelinedStIdle
  ('S n) (BlockInMode BccMode) ChainPoint ChainTip m a
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) 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 (History (Either Text LedgerState)
-> Nat ('S n)
-> ClientPipelinedStIdle
     ('S n)
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     ('S n) (BlockInMode BccMode) ChainPoint ChainTip m a
forall (n :: N).
History (Either Text LedgerState)
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) ChainPoint ChainTip m a
goClientPipelinedStIdle History (Either Text LedgerState)
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 BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
a)
      CSP.SendMsgFindIntersect [ChainPoint]
ps ClientPipelinedStIntersect
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
a -> [ChainPoint]
-> ClientPipelinedStIntersect
     (BlockInMode BccMode) ChainPoint ChainTip m a
-> ClientPipelinedStIdle
     'Z (BlockInMode BccMode) 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 (History (Either Text LedgerState)
-> Nat n
-> ClientPipelinedStIntersect
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIntersect
     (BlockInMode BccMode) ChainPoint ChainTip m a
forall (n :: N).
History (Either Text LedgerState)
-> Nat n
-> ClientPipelinedStIntersect
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIntersect
     (BlockInMode BccMode) ChainPoint ChainTip m a
goClientPipelinedStIntersect History (Either Text LedgerState)
history Nat n
n ClientPipelinedStIntersect
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
a)
      CSP.CollectResponse Maybe
  (m (ClientPipelinedStIdle
        ('S n1)
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a))
a ClientStNext
  n1
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
b -> case Nat n
n of
        Succ Nat n
nPrev -> Maybe
  (m (ClientPipelinedStIdle
        ('S n) (BlockInMode BccMode) ChainPoint ChainTip m a))
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip m a
-> ClientPipelinedStIdle
     ('S n) (BlockInMode BccMode) 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 BccMode, Either Text LedgerState)
      ChainPoint
      ChainTip
      m
      a)
 -> m (ClientPipelinedStIdle
         n (BlockInMode BccMode) ChainPoint ChainTip m a))
-> Maybe
     (m (ClientPipelinedStIdle
           n
           (BlockInMode BccMode, Either Text LedgerState)
           ChainPoint
           ChainTip
           m
           a))
-> Maybe
     (m (ClientPipelinedStIdle
           n (BlockInMode BccMode) ChainPoint ChainTip m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((m (ClientPipelinedStIdle
       n
       (BlockInMode BccMode, Either Text LedgerState)
       ChainPoint
       ChainTip
       m
       a)
  -> m (ClientPipelinedStIdle
          n (BlockInMode BccMode) ChainPoint ChainTip m a))
 -> Maybe
      (m (ClientPipelinedStIdle
            n
            (BlockInMode BccMode, Either Text LedgerState)
            ChainPoint
            ChainTip
            m
            a))
 -> Maybe
      (m (ClientPipelinedStIdle
            n (BlockInMode BccMode) ChainPoint ChainTip m a)))
-> ((ClientPipelinedStIdle
       n
       (BlockInMode BccMode, Either Text LedgerState)
       ChainPoint
       ChainTip
       m
       a
     -> ClientPipelinedStIdle
          n (BlockInMode BccMode) ChainPoint ChainTip m a)
    -> m (ClientPipelinedStIdle
            n
            (BlockInMode BccMode, Either Text LedgerState)
            ChainPoint
            ChainTip
            m
            a)
    -> m (ClientPipelinedStIdle
            n (BlockInMode BccMode) ChainPoint ChainTip m a))
-> (ClientPipelinedStIdle
      n
      (BlockInMode BccMode, Either Text LedgerState)
      ChainPoint
      ChainTip
      m
      a
    -> ClientPipelinedStIdle
         n (BlockInMode BccMode) ChainPoint ChainTip m a)
-> Maybe
     (m (ClientPipelinedStIdle
           n
           (BlockInMode BccMode, Either Text LedgerState)
           ChainPoint
           ChainTip
           m
           a))
-> Maybe
     (m (ClientPipelinedStIdle
           n (BlockInMode BccMode) ChainPoint ChainTip m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientPipelinedStIdle
   n
   (BlockInMode BccMode, Either Text LedgerState)
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle
      n (BlockInMode BccMode) ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        n
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (History (Either Text LedgerState)
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) ChainPoint ChainTip m a
forall (n :: N).
History (Either Text LedgerState)
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) ChainPoint ChainTip m a
goClientPipelinedStIdle History (Either Text LedgerState)
history Nat n
n) Maybe
  (m (ClientPipelinedStIdle
        n
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a))
Maybe
  (m (ClientPipelinedStIdle
        ('S n1)
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a))
a) (History (Either Text LedgerState)
-> Nat n
-> ClientStNext
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip m a
forall (n :: N).
History (Either Text LedgerState)
-> Nat n
-> ClientStNext
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip m a
goClientStNext History (Either Text LedgerState)
history Nat n
nPrev ClientStNext
  n1
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
ClientStNext
  n
  (BlockInMode BccMode, Either Text LedgerState)
  ChainPoint
  ChainTip
  m
  a
b)
      CSP.SendMsgDone a
a -> a
-> ClientPipelinedStIdle
     'Z (BlockInMode BccMode) 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
      :: History (Either Text LedgerState)
      -> Nat n
      -> CSP.ClientStNext n (BlockInMode BccMode, Either Text LedgerState) ChainPoint ChainTip m a
      -> CSP.ClientStNext n (BlockInMode BccMode                           ) ChainPoint ChainTip m a
    goClientStNext :: History (Either Text LedgerState)
-> Nat n
-> ClientStNext
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientStNext n (BlockInMode BccMode) ChainPoint ChainTip m a
goClientStNext History (Either Text LedgerState)
history Nat n
n (CSP.ClientStNext (BlockInMode BccMode, Either Text LedgerState)
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollForward ChainPoint
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollBackward) = (BlockInMode BccMode
 -> ChainTip
 -> m (ClientPipelinedStIdle
         n (BlockInMode BccMode) ChainPoint ChainTip m a))
-> (ChainPoint
    -> ChainTip
    -> m (ClientPipelinedStIdle
            n (BlockInMode BccMode) ChainPoint ChainTip m a))
-> ClientStNext n (BlockInMode BccMode) 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 BccMode
blkInMode@(BlockInMode blk :: Block era
blk@(Block (BlockHeader SlotNo
slotNo Hash BlockHeader
_ BlockNo
_) [Tx era]
_) EraInMode era BccMode
_) ChainTip
tip -> let
          newLedgerStateE :: Either Text LedgerState
newLedgerStateE = case Int
-> History (Either Text LedgerState)
-> Maybe
     (SlotNo, Either Text LedgerState, WithOrigin (BlockInMode BccMode))
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
0 History (Either Text LedgerState)
history of
            Maybe
  (SlotNo, Either Text LedgerState, WithOrigin (BlockInMode BccMode))
Nothing -> Text -> Either Text LedgerState
forall a b. a -> Either a b
Left Text
"Rolled back too far."
            Just (SlotNo
_, Left Text
err, WithOrigin (BlockInMode BccMode)
_) -> Text -> Either Text LedgerState
forall a b. a -> Either a b
Left Text
err
            Just (SlotNo
_, Right LedgerState
oldLedgerState, WithOrigin (BlockInMode BccMode)
_) -> Env
-> LedgerState
-> ValidationMode
-> Block era
-> Either Text LedgerState
forall era.
Env
-> LedgerState
-> ValidationMode
-> Block era
-> Either Text LedgerState
applyBlock
                  Env
env
                  LedgerState
oldLedgerState
                  ValidationMode
validationMode
                  Block era
blk
          (History (Either Text LedgerState)
history', History (Either Text LedgerState)
_) = Env
-> History (Either Text LedgerState)
-> SlotNo
-> Either Text LedgerState
-> BlockInMode BccMode
-> (History (Either Text LedgerState),
    History (Either Text LedgerState))
forall a.
Env
-> History a
-> SlotNo
-> a
-> BlockInMode BccMode
-> (History a, History a)
pushLedgerState Env
env History (Either Text LedgerState)
history SlotNo
slotNo Either Text LedgerState
newLedgerStateE BlockInMode BccMode
blkInMode
        in History (Either Text LedgerState)
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) ChainPoint ChainTip m a
forall (n :: N).
History (Either Text LedgerState)
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) ChainPoint ChainTip m a
goClientPipelinedStIdle History (Either Text LedgerState)
history' Nat n
n (ClientPipelinedStIdle
   n
   (BlockInMode BccMode, Either Text LedgerState)
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle
      n (BlockInMode BccMode) ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        n
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BlockInMode BccMode, Either Text LedgerState)
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollForward (BlockInMode BccMode
blkInMode, Either Text LedgerState
newLedgerStateE) ChainTip
tip
      )
      (\ChainPoint
point ChainTip
tip -> let
          history' :: History (Either Text LedgerState)
history' = case ChainPoint
point of
                        ChainPoint
ChainPointAtGenesis -> History (Either Text LedgerState)
initialLedgerStateHistory
                        ChainPoint SlotNo
slotNo Hash BlockHeader
_ -> History (Either Text LedgerState)
-> SlotNo -> History (Either Text LedgerState)
forall a. History a -> SlotNo -> History a
rollBackLedgerStateHist History (Either Text LedgerState)
history SlotNo
slotNo
        in History (Either Text LedgerState)
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) ChainPoint ChainTip m a
forall (n :: N).
History (Either Text LedgerState)
-> Nat n
-> ClientPipelinedStIdle
     n
     (BlockInMode BccMode, Either Text LedgerState)
     ChainPoint
     ChainTip
     m
     a
-> ClientPipelinedStIdle
     n (BlockInMode BccMode) ChainPoint ChainTip m a
goClientPipelinedStIdle History (Either Text LedgerState)
history' Nat n
n (ClientPipelinedStIdle
   n
   (BlockInMode BccMode, Either Text LedgerState)
   ChainPoint
   ChainTip
   m
   a
 -> ClientPipelinedStIdle
      n (BlockInMode BccMode) ChainPoint ChainTip m a)
-> m (ClientPipelinedStIdle
        n
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a)
-> m (ClientPipelinedStIdle
        n (BlockInMode BccMode) ChainPoint ChainTip m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainPoint
-> ChainTip
-> m (ClientPipelinedStIdle
        n
        (BlockInMode BccMode, Either Text LedgerState)
        ChainPoint
        ChainTip
        m
        a)
recvMsgRollBackward ChainPoint
point ChainTip
tip
      )

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

    initialLedgerStateHistory :: History (Either Text LedgerState)
    initialLedgerStateHistory :: History (Either Text LedgerState)
initialLedgerStateHistory = (SlotNo, Either Text LedgerState, WithOrigin (BlockInMode BccMode))
-> History (Either Text LedgerState)
forall a. a -> Seq a
Seq.singleton (SlotNo
0, LedgerState -> Either Text LedgerState
forall a b. b -> Either a b
Right LedgerState
ledgerState0, WithOrigin (BlockInMode BccMode)
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 after applying the new block
-- * The new block
--
type LedgerStateHistory = History LedgerState
type History a = Seq (SlotNo, a, WithOrigin (BlockInMode BccMode))

-- | Add a new ledger state to the history
pushLedgerState
  :: Env                -- ^ Environement 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 BccMode
                        -- ^ 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 exisiting items that are now past the security parameter
  --      and hence can no longer be rolled back.
  --   )
pushLedgerState :: Env
-> History a
-> SlotNo
-> a
-> BlockInMode BccMode
-> (History a, History a)
pushLedgerState Env
env History a
hist SlotNo
ix a
st BlockInMode BccMode
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 BccMode -> WithOrigin (BlockInMode BccMode)
forall t. t -> WithOrigin t
At BlockInMode BccMode
block) (SlotNo, a, WithOrigin (BlockInMode BccMode))
-> 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 BccMode)) -> 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 BccMode)) -> SlotNo)
-> (SlotNo, a, WithOrigin (BlockInMode BccMode))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(SlotNo
x,a
_,WithOrigin (BlockInMode BccMode)
_) -> 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
      GenesisBcc NodeConfig
_ Config
bCfg SophieConfig
sCfg AurumGenesis
_
        | ProtocolMagicId -> Word32
Bcc.Crypto.ProtocolMagic.unProtocolMagicId (Config -> ProtocolMagicId
Bcc.Chain.Genesis.configProtocolMagicId Config
bCfg) Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= SophieGenesis (SophieEra StandardCrypto) -> Word32
forall era. SophieGenesis era -> Word32
Sophie.Spec.sgNetworkMagic (SophieConfig -> SophieGenesis (SophieEra StandardCrypto)
scConfig SophieConfig
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
NEBccConfig (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
Bcc.Crypto.ProtocolMagic.unProtocolMagicId (ProtocolMagicId -> Word32) -> ProtocolMagicId -> Word32
forall a b. (a -> b) -> a -> b
$ Config -> ProtocolMagicId
Bcc.Chain.Genesis.configProtocolMagicId Config
bCfg)
                , Text
" /= ", Word32 -> Text
forall a. Show a => a -> Text
textShow (SophieGenesis (SophieEra StandardCrypto) -> Word32
forall era. SophieGenesis era -> Word32
Sophie.Spec.sgNetworkMagic (SophieGenesis (SophieEra StandardCrypto) -> Word32)
-> SophieGenesis (SophieEra StandardCrypto) -> Word32
forall a b. (a -> b) -> a -> b
$ SophieConfig -> SophieGenesis (SophieEra StandardCrypto)
scConfig SophieConfig
sCfg)
                ]
        | GenesisData -> UTCTime
Bcc.Chain.Genesis.gdStartTime (Config -> GenesisData
Bcc.Chain.Genesis.configGenesisData Config
bCfg) UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
/= SophieGenesis (SophieEra StandardCrypto) -> UTCTime
forall era. SophieGenesis era -> UTCTime
Sophie.Spec.sgSystemStart (SophieConfig -> SophieGenesis (SophieEra StandardCrypto)
scConfig SophieConfig
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
NEBccConfig (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
Bcc.Chain.Genesis.gdStartTime (GenesisData -> UTCTime) -> GenesisData -> UTCTime
forall a b. (a -> b) -> a -> b
$ Config -> GenesisData
Bcc.Chain.Genesis.configGenesisData Config
bCfg)
                , Text
" /= ", UTCTime -> Text
forall a. Show a => a -> Text
textShow (SophieGenesis (SophieEra StandardCrypto) -> UTCTime
forall era. SophieGenesis era -> UTCTime
Sophie.Spec.sgSystemStart (SophieGenesis (SophieEra StandardCrypto) -> UTCTime)
-> SophieGenesis (SophieEra StandardCrypto) -> UTCTime
forall a b. (a -> b) -> a -> b
$ SophieConfig -> SophieGenesis (SophieEra StandardCrypto)
scConfig SophieConfig
sCfg)
                ]
        | Bool
otherwise ->
            let
              topLevelConfig :: TopLevelConfig (HardForkBlock (BccEras StandardCrypto))
topLevelConfig = ProtocolInfo IO (HardForkBlock (BccEras StandardCrypto))
-> TopLevelConfig (HardForkBlock (BccEras StandardCrypto))
forall (m :: * -> *) b. ProtocolInfo m b -> TopLevelConfig b
Consensus.pInfoConfig (GenesisConfig
-> ProtocolInfo IO (HardForkBlock (BccEras StandardCrypto))
mkProtocolInfoBcc 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 (BccEras StandardCrypto)
-> ConsensusConfig (HardForkProtocol (BccEras StandardCrypto))
-> Env
Env
                  { envLedgerConfig :: HardForkLedgerConfig (BccEras StandardCrypto)
envLedgerConfig = TopLevelConfig (HardForkBlock (BccEras StandardCrypto))
-> LedgerConfig (HardForkBlock (BccEras StandardCrypto))
forall blk. TopLevelConfig blk -> LedgerConfig blk
Consensus.topLevelConfigLedger TopLevelConfig (HardForkBlock (BccEras StandardCrypto))
topLevelConfig
                  , envProtocolConfig :: ConsensusConfig (HardForkProtocol (BccEras StandardCrypto))
envProtocolConfig = TopLevelConfig (HardForkBlock (BccEras StandardCrypto))
-> ConsensusConfig
     (BlockProtocol (HardForkBlock (BccEras StandardCrypto)))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
Consensus.topLevelConfigProtocol TopLevelConfig (HardForkBlock (BccEras StandardCrypto))
topLevelConfig
                  }

readNetworkConfig :: NetworkConfigFile -> ExceptT Text IO NodeConfig
readNetworkConfig :: NetworkConfigFile -> ExceptT Text IO NodeConfig
readNetworkConfig (NetworkConfigFile FilePath
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
=<< FilePath -> Text -> ExceptT Text IO ByteString
readByteString FilePath
ncf Text
"node"
    NodeConfig -> ExceptT Text IO NodeConfig
forall (m :: * -> *) a. Monad m => a -> m a
return NodeConfig
ncfg
      { ncColeGenesisFile :: GenesisFile
ncColeGenesisFile = (FilePath -> FilePath) -> GenesisFile -> GenesisFile
adjustGenesisFilePath (FilePath -> FilePath -> FilePath
mkAdjustPath FilePath
ncf) (NodeConfig -> GenesisFile
ncColeGenesisFile NodeConfig
ncfg)
      , ncSophieGenesisFile :: GenesisFile
ncSophieGenesisFile = (FilePath -> FilePath) -> GenesisFile -> GenesisFile
adjustGenesisFilePath (FilePath -> FilePath -> FilePath
mkAdjustPath FilePath
ncf) (NodeConfig -> GenesisFile
ncSophieGenesisFile NodeConfig
ncfg)
      , ncAurumGenesisFile :: GenesisFile
ncAurumGenesisFile = (FilePath -> FilePath) -> GenesisFile -> GenesisFile
adjustGenesisFilePath (FilePath -> FilePath -> FilePath
mkAdjustPath FilePath
ncf) (NodeConfig -> GenesisFile
ncAurumGenesisFile NodeConfig
ncfg)
      }

data NodeConfig = NodeConfig
  { NodeConfig -> Maybe Double
ncPBftSignatureThreshold :: !(Maybe Double)
  , NodeConfig -> GenesisFile
ncColeGenesisFile :: !GenesisFile
  , NodeConfig -> GenesisHashCole
ncColeGenesisHash :: !GenesisHashCole
  , NodeConfig -> GenesisFile
ncSophieGenesisFile :: !GenesisFile
  , NodeConfig -> GenesisHashSophie
ncSophieGenesisHash :: !GenesisHashSophie
  , NodeConfig -> GenesisFile
ncAurumGenesisFile :: !GenesisFile
  , NodeConfig -> GenesisHashAurum
ncAurumGenesisHash :: !GenesisHashAurum
  , NodeConfig -> RequiresNetworkMagic
ncRequiresNetworkMagic :: !Bcc.Crypto.RequiresNetworkMagic
  , NodeConfig -> SoftwareVersion
ncColeSoftwareVersion :: !Bcc.Chain.Update.SoftwareVersion
  , NodeConfig -> ProtocolVersion
ncColeProtocolVersion :: !Bcc.Chain.Update.ProtocolVersion

  -- Per-era parameters for the hardfok transitions:
  , NodeConfig
-> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
ncColeToSophie   :: !(Consensus.ProtocolTransitionParamsSophieBased
                              Sophie.StandardSophie)
  , NodeConfig
-> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
ncSophieToEvie :: !(Consensus.ProtocolTransitionParamsSophieBased
                              Sophie.StandardEvie)
  , NodeConfig
-> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
ncEvieToJen    :: !(Consensus.ProtocolTransitionParamsSophieBased
                              Sophie.StandardJen)
  , NodeConfig -> TriggerHardFork
ncJenToAurum     :: !Consensus.TriggerHardFork
  }

instance FromJSON NodeConfig where
  parseJSON :: Value -> Parser NodeConfig
parseJSON Value
v =
      FilePath
-> (Object -> Parser NodeConfig) -> Value -> Parser NodeConfig
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject FilePath
"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
-> GenesisHashCole
-> GenesisFile
-> GenesisHashSophie
-> GenesisFile
-> GenesisHashAurum
-> RequiresNetworkMagic
-> SoftwareVersion
-> ProtocolVersion
-> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
-> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
-> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
-> TriggerHardFork
-> NodeConfig
NodeConfig
          (Maybe Double
 -> GenesisFile
 -> GenesisHashCole
 -> GenesisFile
 -> GenesisHashSophie
 -> GenesisFile
 -> GenesisHashAurum
 -> RequiresNetworkMagic
 -> SoftwareVersion
 -> ProtocolVersion
 -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
 -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
 -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
 -> TriggerHardFork
 -> NodeConfig)
-> Parser (Maybe Double)
-> Parser
     (GenesisFile
      -> GenesisHashCole
      -> GenesisFile
      -> GenesisHashSophie
      -> GenesisFile
      -> GenesisHashAurum
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser (Maybe Double)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"PBftSignatureThreshold"
          Parser
  (GenesisFile
   -> GenesisHashCole
   -> GenesisFile
   -> GenesisHashSophie
   -> GenesisFile
   -> GenesisHashAurum
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisFile
-> Parser
     (GenesisHashCole
      -> GenesisFile
      -> GenesisHashSophie
      -> GenesisFile
      -> GenesisHashAurum
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> GenesisFile) -> Parser FilePath -> Parser GenesisFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> GenesisFile
GenesisFile (Object
o Object -> Text -> Parser FilePath
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"ColeGenesisFile")
          Parser
  (GenesisHashCole
   -> GenesisFile
   -> GenesisHashSophie
   -> GenesisFile
   -> GenesisHashAurum
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisHashCole
-> Parser
     (GenesisFile
      -> GenesisHashSophie
      -> GenesisFile
      -> GenesisHashAurum
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> GenesisHashCole) -> Parser Text -> Parser GenesisHashCole
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> GenesisHashCole
GenesisHashCole (Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"ColeGenesisHash")
          Parser
  (GenesisFile
   -> GenesisHashSophie
   -> GenesisFile
   -> GenesisHashAurum
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisFile
-> Parser
     (GenesisHashSophie
      -> GenesisFile
      -> GenesisHashAurum
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> GenesisFile) -> Parser FilePath -> Parser GenesisFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> GenesisFile
GenesisFile (Object
o Object -> Text -> Parser FilePath
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"SophieGenesisFile")
          Parser
  (GenesisHashSophie
   -> GenesisFile
   -> GenesisHashAurum
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisHashSophie
-> Parser
     (GenesisFile
      -> GenesisHashAurum
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Hash Blake2b_256 ByteString -> GenesisHashSophie)
-> Parser (Hash Blake2b_256 ByteString) -> Parser GenesisHashSophie
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Hash Blake2b_256 ByteString -> GenesisHashSophie
GenesisHashSophie (Object
o Object -> Text -> Parser (Hash Blake2b_256 ByteString)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"SophieGenesisHash")
          Parser
  (GenesisFile
   -> GenesisHashAurum
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisFile
-> Parser
     (GenesisHashAurum
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FilePath -> GenesisFile) -> Parser FilePath -> Parser GenesisFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> GenesisFile
GenesisFile (Object
o Object -> Text -> Parser FilePath
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"AurumGenesisFile")
          Parser
  (GenesisHashAurum
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisHashAurum
-> Parser
     (RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Hash Blake2b_256 ByteString -> GenesisHashAurum)
-> Parser (Hash Blake2b_256 ByteString) -> Parser GenesisHashAurum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Hash Blake2b_256 ByteString -> GenesisHashAurum
GenesisHashAurum (Object
o Object -> Text -> Parser (Hash Blake2b_256 ByteString)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"AurumGenesisHash")
          Parser
  (RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser RequiresNetworkMagic
-> Parser
     (SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser RequiresNetworkMagic
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"RequiresNetworkMagic"
          Parser
  (SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser SoftwareVersion
-> Parser
     (ProtocolVersion
      -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser SoftwareVersion
parseColeSoftwareVersion Object
o
          Parser
  (ProtocolVersion
   -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser ProtocolVersion
-> Parser
     (ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser ProtocolVersion
parseColeProtocolVersion Object
o
          Parser
  (ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser
     (ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto))
-> Parser
     (ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
      -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TranslationContext (SophieEra StandardCrypto)
-> TriggerHardFork
-> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
forall era.
TranslationContext era
-> TriggerHardFork -> ProtocolTransitionParamsSophieBased era
Consensus.ProtocolTransitionParamsSophieBased ()
                 (TriggerHardFork
 -> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto))
-> Parser TriggerHardFork
-> Parser
     (ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser TriggerHardFork
parseSophieHardForkEpoch Object
o)
          Parser
  (ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
   -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser
     (ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto))
-> Parser
     (ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
      -> TriggerHardFork -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TranslationContext (EvieEra StandardCrypto)
-> TriggerHardFork
-> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
forall era.
TranslationContext era
-> TriggerHardFork -> ProtocolTransitionParamsSophieBased era
Consensus.ProtocolTransitionParamsSophieBased ()
                 (TriggerHardFork
 -> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto))
-> Parser TriggerHardFork
-> Parser
     (ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser TriggerHardFork
parseEvieHardForkEpoch Object
o)
          Parser
  (ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
   -> TriggerHardFork -> NodeConfig)
-> Parser
     (ProtocolTransitionParamsSophieBased (JenEra StandardCrypto))
-> Parser (TriggerHardFork -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TranslationContext (JenEra StandardCrypto)
-> TriggerHardFork
-> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
forall era.
TranslationContext era
-> TriggerHardFork -> ProtocolTransitionParamsSophieBased era
Consensus.ProtocolTransitionParamsSophieBased ()
                 (TriggerHardFork
 -> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto))
-> Parser TriggerHardFork
-> Parser
     (ProtocolTransitionParamsSophieBased (JenEra StandardCrypto))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser TriggerHardFork
parseJenHardForkEpoch 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
parseAurumHardForkEpoch Object
o

      parseColeProtocolVersion :: Object -> Data.Aeson.Types.Internal.Parser Bcc.Chain.Update.ProtocolVersion
      parseColeProtocolVersion :: Object -> Parser ProtocolVersion
parseColeProtocolVersion Object
o =
        Word16 -> Word16 -> ProtocolVersion
Bcc.Chain.Update.ProtocolVersion
          (Word16 -> Word16 -> ProtocolVersion)
-> Parser Word16 -> Parser (Word16 -> ProtocolVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser Word16
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"LastKnownBlockVersion-Major"
          Parser (Word16 -> ProtocolVersion)
-> Parser Word16 -> Parser ProtocolVersion
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Word16
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"LastKnownBlockVersion-Sentry"

      parseColeSoftwareVersion :: Object -> Data.Aeson.Types.Internal.Parser Bcc.Chain.Update.SoftwareVersion
      parseColeSoftwareVersion :: Object -> Parser SoftwareVersion
parseColeSoftwareVersion Object
o =
        ApplicationName -> Word32 -> SoftwareVersion
Bcc.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
Bcc.Chain.Update.ApplicationName (Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"ApplicationName")
          Parser (Word32 -> SoftwareVersion)
-> Parser Word32 -> Parser SoftwareVersion
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Word32
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"ApplicationVersion"

      parseSophieHardForkEpoch :: Object -> Data.Aeson.Types.Internal.Parser Consensus.TriggerHardFork
      parseSophieHardForkEpoch :: Object -> Parser TriggerHardFork
parseSophieHardForkEpoch 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 -> Text -> Parser EpochNo
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"TestSophieHardForkAtEpoch"
          , 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
          ]

      parseEvieHardForkEpoch :: Object -> Data.Aeson.Types.Internal.Parser Consensus.TriggerHardFork
      parseEvieHardForkEpoch :: Object -> Parser TriggerHardFork
parseEvieHardForkEpoch 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 -> Text -> Parser EpochNo
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"TestEvieHardForkAtEpoch"
          , 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
          ]

      parseJenHardForkEpoch :: Object -> Data.Aeson.Types.Internal.Parser Consensus.TriggerHardFork
      parseJenHardForkEpoch :: Object -> Parser TriggerHardFork
parseJenHardForkEpoch 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 -> Text -> Parser EpochNo
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"TestJenHardForkAtEpoch"
          , 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
          ]

      parseAurumHardForkEpoch :: Object -> Data.Aeson.Types.Internal.Parser Consensus.TriggerHardFork
      parseAurumHardForkEpoch :: Object -> Parser TriggerHardFork
parseAurumHardForkEpoch 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 -> Text -> Parser EpochNo
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"TestAurumHardForkAtEpoch"
          , 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
          ]

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 :: (FilePath -> FilePath) -> GenesisFile -> GenesisFile
adjustGenesisFilePath FilePath -> FilePath
f (GenesisFile FilePath
p) = FilePath -> GenesisFile
GenesisFile (FilePath -> FilePath
f FilePath
p)

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

readByteString :: FilePath -> Text -> ExceptT Text IO ByteString
readByteString :: FilePath -> Text -> ExceptT Text IO ByteString
readByteString FilePath
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
<$> FilePath -> IO ByteString
BS.readFile FilePath
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 : ", FilePath -> Text
Text.pack FilePath
fp ]

initLedgerStateVar :: GenesisConfig -> LedgerState
initLedgerStateVar :: GenesisConfig -> LedgerState
initLedgerStateVar GenesisConfig
genesisConfig = LedgerState :: LedgerState (HardForkBlock (BccEras StandardCrypto)) -> LedgerState
LedgerState
  { clsState :: LedgerState (HardForkBlock (BccEras StandardCrypto))
clsState = ExtLedgerState (HardForkBlock (BccEras StandardCrypto))
-> LedgerState (HardForkBlock (BccEras StandardCrypto))
forall blk. ExtLedgerState blk -> LedgerState blk
Ledger.ledgerState (ExtLedgerState (HardForkBlock (BccEras StandardCrypto))
 -> LedgerState (HardForkBlock (BccEras StandardCrypto)))
-> ExtLedgerState (HardForkBlock (BccEras StandardCrypto))
-> LedgerState (HardForkBlock (BccEras StandardCrypto))
forall a b. (a -> b) -> a -> b
$ ProtocolInfo IO (HardForkBlock (BccEras StandardCrypto))
-> ExtLedgerState (HardForkBlock (BccEras StandardCrypto))
forall (m :: * -> *) b. ProtocolInfo m b -> ExtLedgerState b
Consensus.pInfoInitLedger ProtocolInfo IO (HardForkBlock (BccEras StandardCrypto))
protocolInfo
  }
  where
    protocolInfo :: ProtocolInfo IO (HardForkBlock (BccEras StandardCrypto))
protocolInfo = GenesisConfig
-> ProtocolInfo IO (HardForkBlock (BccEras StandardCrypto))
mkProtocolInfoBcc GenesisConfig
genesisConfig

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

data LedgerStateEvents = LedgerStateEvents
  { LedgerStateEvents
-> LedgerState (HardForkBlock (BccEras StandardCrypto))
lseState ::
      Ledger.LedgerState
        ( HFC.HardForkBlock
            (Consensus.BccEras Consensus.StandardCrypto)
        ),
    LedgerStateEvents -> [LedgerEvent]
lseEvents :: [LedgerEvent]
  }

toLedgerStateEvents ::
  LedgerResult
    ( Sophie.LedgerState
        (HFC.HardForkBlock (Consensus.BccEras Sophie.StandardCrypto))
    )
    ( Sophie.LedgerState
        (HFC.HardForkBlock (Consensus.BccEras Sophie.StandardCrypto))
    ) ->
  LedgerStateEvents
toLedgerStateEvents :: LedgerResult
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
-> LedgerStateEvents
toLedgerStateEvents LedgerResult
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
lr = LedgerStateEvents :: LedgerState (HardForkBlock (BccEras StandardCrypto))
-> [LedgerEvent] -> LedgerStateEvents
LedgerStateEvents
  { lseState :: LedgerState (HardForkBlock (BccEras StandardCrypto))
lseState = LedgerResult
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
-> LedgerState (HardForkBlock (BccEras StandardCrypto))
forall l a. LedgerResult l a -> a
lrResult LedgerResult
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
lr
  , lseEvents :: [LedgerEvent]
lseEvents = (OneEraLedgerEvent (BccEras StandardCrypto) -> Maybe LedgerEvent)
-> [OneEraLedgerEvent (BccEras StandardCrypto)] -> [LedgerEvent]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (WrapLedgerEvent (HardForkBlock (BccEras StandardCrypto))
-> Maybe LedgerEvent
forall blk.
ConvertLedgerEvent blk =>
WrapLedgerEvent blk -> Maybe LedgerEvent
toLedgerEvent
      (WrapLedgerEvent (HardForkBlock (BccEras StandardCrypto))
 -> Maybe LedgerEvent)
-> (OneEraLedgerEvent (BccEras StandardCrypto)
    -> WrapLedgerEvent (HardForkBlock (BccEras StandardCrypto)))
-> OneEraLedgerEvent (BccEras StandardCrypto)
-> Maybe LedgerEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuxLedgerEvent
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
-> WrapLedgerEvent (HardForkBlock (BccEras StandardCrypto))
forall blk. AuxLedgerEvent (LedgerState blk) -> WrapLedgerEvent blk
WrapLedgerEvent @(HFC.HardForkBlock (Consensus.BccEras Sophie.StandardCrypto)))
      ([OneEraLedgerEvent (BccEras StandardCrypto)] -> [LedgerEvent])
-> [OneEraLedgerEvent (BccEras StandardCrypto)] -> [LedgerEvent]
forall a b. (a -> b) -> a -> b
$ LedgerResult
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
-> [AuxLedgerEvent
      (LedgerState (HardForkBlock (BccEras StandardCrypto)))]
forall l a. LedgerResult l a -> [AuxLedgerEvent l]
lrEvents LedgerResult
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
lr
  }

-- Usually only one constructor, but may have two when we are preparing for a HFC event.
data GenesisConfig
  = GenesisBcc
      !NodeConfig
      !Bcc.Chain.Genesis.Config
      !SophieConfig
      !AurumGenesis

data SophieConfig = SophieConfig
  { SophieConfig -> SophieGenesis (SophieEra StandardCrypto)
scConfig :: !(Sophie.Spec.SophieGenesis Sophie.StandardSophie)
  , SophieConfig -> GenesisHashSophie
scGenesisHash :: !GenesisHashSophie
  }

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


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

newtype GenesisHashSophie = GenesisHashSophie
  { GenesisHashSophie -> Hash Blake2b_256 ByteString
unGenesisHashSophie :: Bcc.Crypto.Hash.Class.Hash Bcc.Crypto.Hash.Blake2b.Blake2b_256 ByteString
  } deriving newtype (GenesisHashSophie -> GenesisHashSophie -> Bool
(GenesisHashSophie -> GenesisHashSophie -> Bool)
-> (GenesisHashSophie -> GenesisHashSophie -> Bool)
-> Eq GenesisHashSophie
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenesisHashSophie -> GenesisHashSophie -> Bool
$c/= :: GenesisHashSophie -> GenesisHashSophie -> Bool
== :: GenesisHashSophie -> GenesisHashSophie -> Bool
$c== :: GenesisHashSophie -> GenesisHashSophie -> Bool
Eq, Int -> GenesisHashSophie -> FilePath -> FilePath
[GenesisHashSophie] -> FilePath -> FilePath
GenesisHashSophie -> FilePath
(Int -> GenesisHashSophie -> FilePath -> FilePath)
-> (GenesisHashSophie -> FilePath)
-> ([GenesisHashSophie] -> FilePath -> FilePath)
-> Show GenesisHashSophie
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [GenesisHashSophie] -> FilePath -> FilePath
$cshowList :: [GenesisHashSophie] -> FilePath -> FilePath
show :: GenesisHashSophie -> FilePath
$cshow :: GenesisHashSophie -> FilePath
showsPrec :: Int -> GenesisHashSophie -> FilePath -> FilePath
$cshowsPrec :: Int -> GenesisHashSophie -> FilePath -> FilePath
Show)

newtype GenesisHashAurum = GenesisHashAurum
  { GenesisHashAurum -> Hash Blake2b_256 ByteString
unGenesisHashAurum :: Bcc.Crypto.Hash.Class.Hash Bcc.Crypto.Hash.Blake2b.Blake2b_256 ByteString
  } deriving newtype (GenesisHashAurum -> GenesisHashAurum -> Bool
(GenesisHashAurum -> GenesisHashAurum -> Bool)
-> (GenesisHashAurum -> GenesisHashAurum -> Bool)
-> Eq GenesisHashAurum
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenesisHashAurum -> GenesisHashAurum -> Bool
$c/= :: GenesisHashAurum -> GenesisHashAurum -> Bool
== :: GenesisHashAurum -> GenesisHashAurum -> Bool
$c== :: GenesisHashAurum -> GenesisHashAurum -> Bool
Eq, Int -> GenesisHashAurum -> FilePath -> FilePath
[GenesisHashAurum] -> FilePath -> FilePath
GenesisHashAurum -> FilePath
(Int -> GenesisHashAurum -> FilePath -> FilePath)
-> (GenesisHashAurum -> FilePath)
-> ([GenesisHashAurum] -> FilePath -> FilePath)
-> Show GenesisHashAurum
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [GenesisHashAurum] -> FilePath -> FilePath
$cshowList :: [GenesisHashAurum] -> FilePath -> FilePath
show :: GenesisHashAurum -> FilePath
$cshow :: GenesisHashAurum -> FilePath
showsPrec :: Int -> GenesisHashAurum -> FilePath -> FilePath
$cshowsPrec :: Int -> GenesisHashAurum -> FilePath -> FilePath
Show)

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

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

newtype VestedHashSophie = VestedHashSophie
  { VestedHashSophie -> Hash Blake2b_256 ByteString
_unVestedHashSophie :: Bcc.Crypto.Hash.Class.Hash Bcc.Crypto.Hash.Blake2b.Blake2b_256 ByteString
  } deriving newtype (VestedHashSophie -> VestedHashSophie -> Bool
(VestedHashSophie -> VestedHashSophie -> Bool)
-> (VestedHashSophie -> VestedHashSophie -> Bool)
-> Eq VestedHashSophie
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VestedHashSophie -> VestedHashSophie -> Bool
$c/= :: VestedHashSophie -> VestedHashSophie -> Bool
== :: VestedHashSophie -> VestedHashSophie -> Bool
$c== :: VestedHashSophie -> VestedHashSophie -> Bool
Eq, Int -> VestedHashSophie -> FilePath -> FilePath
[VestedHashSophie] -> FilePath -> FilePath
VestedHashSophie -> FilePath
(Int -> VestedHashSophie -> FilePath -> FilePath)
-> (VestedHashSophie -> FilePath)
-> ([VestedHashSophie] -> FilePath -> FilePath)
-> Show VestedHashSophie
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [VestedHashSophie] -> FilePath -> FilePath
$cshowList :: [VestedHashSophie] -> FilePath -> FilePath
show :: VestedHashSophie -> FilePath
$cshow :: VestedHashSophie -> FilePath
showsPrec :: Int -> VestedHashSophie -> FilePath -> FilePath
$cshowsPrec :: Int -> VestedHashSophie -> FilePath -> FilePath
Show)

newtype VestedHashAurum = VestedHashAurum
  { VestedHashAurum -> Hash Blake2b_256 ByteString
_unVestedHashAurum :: Bcc.Crypto.Hash.Class.Hash Bcc.Crypto.Hash.Blake2b.Blake2b_256 ByteString
  } deriving newtype (VestedHashAurum -> VestedHashAurum -> Bool
(VestedHashAurum -> VestedHashAurum -> Bool)
-> (VestedHashAurum -> VestedHashAurum -> Bool)
-> Eq VestedHashAurum
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VestedHashAurum -> VestedHashAurum -> Bool
$c/= :: VestedHashAurum -> VestedHashAurum -> Bool
== :: VestedHashAurum -> VestedHashAurum -> Bool
$c== :: VestedHashAurum -> VestedHashAurum -> Bool
Eq, Int -> VestedHashAurum -> FilePath -> FilePath
[VestedHashAurum] -> FilePath -> FilePath
VestedHashAurum -> FilePath
(Int -> VestedHashAurum -> FilePath -> FilePath)
-> (VestedHashAurum -> FilePath)
-> ([VestedHashAurum] -> FilePath -> FilePath)
-> Show VestedHashAurum
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [VestedHashAurum] -> FilePath -> FilePath
$cshowList :: [VestedHashAurum] -> FilePath -> FilePath
show :: VestedHashAurum -> FilePath
$cshow :: VestedHashAurum -> FilePath
showsPrec :: Int -> VestedHashAurum -> FilePath -> FilePath
$cshowsPrec :: Int -> VestedHashAurum -> FilePath -> FilePath
Show)

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

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

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

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

mkProtocolInfoBcc ::
  GenesisConfig ->
  Consensus.ProtocolInfo
    IO
    (HFC.HardForkBlock
            (Consensus.BccEras Consensus.StandardCrypto))
mkProtocolInfoBcc :: GenesisConfig
-> ProtocolInfo IO (HardForkBlock (BccEras StandardCrypto))
mkProtocolInfoBcc (GenesisBcc NodeConfig
dnc Config
coleGenesis SophieConfig
sophieGenesis AurumGenesis
aurumGenesis)
  = ProtocolParamsCole
-> ProtocolParamsSophieBased (SophieEra StandardCrypto)
-> ProtocolParamsSophie StandardCrypto
-> ProtocolParamsEvie StandardCrypto
-> ProtocolParamsJen StandardCrypto
-> ProtocolParamsAurum StandardCrypto
-> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
-> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
-> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
-> ProtocolTransitionParamsSophieBased (AurumEra StandardCrypto)
-> ProtocolInfo IO (HardForkBlock (BccEras StandardCrypto))
forall c (m :: * -> *).
(IOLike m, BccHardForkConstraints c) =>
ProtocolParamsCole
-> ProtocolParamsSophieBased (SophieEra c)
-> ProtocolParamsSophie c
-> ProtocolParamsEvie c
-> ProtocolParamsJen c
-> ProtocolParamsAurum c
-> ProtocolTransitionParamsSophieBased (SophieEra c)
-> ProtocolTransitionParamsSophieBased (EvieEra c)
-> ProtocolTransitionParamsSophieBased (JenEra c)
-> ProtocolTransitionParamsSophieBased (AurumEra c)
-> ProtocolInfo m (BccBlock c)
Consensus.protocolInfoBcc
          ProtocolParamsCole :: Config
-> Maybe PBftSignatureThreshold
-> ProtocolVersion
-> SoftwareVersion
-> Maybe ColeLeaderCredentials
-> Overrides ColeBlock
-> ProtocolParamsCole
Consensus.ProtocolParamsCole
            { $sel:coleGenesis:ProtocolParamsCole :: Config
Consensus.coleGenesis = Config
coleGenesis
            , $sel:colePbftSignatureThreshold:ProtocolParamsCole :: Maybe PBftSignatureThreshold
Consensus.colePbftSignatureThreshold = 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:coleProtocolVersion:ProtocolParamsCole :: ProtocolVersion
Consensus.coleProtocolVersion = NodeConfig -> ProtocolVersion
ncColeProtocolVersion NodeConfig
dnc
            , $sel:coleSoftwareVersion:ProtocolParamsCole :: SoftwareVersion
Consensus.coleSoftwareVersion = NodeConfig -> SoftwareVersion
ncColeSoftwareVersion NodeConfig
dnc
            , $sel:coleLeaderCredentials:ProtocolParamsCole :: Maybe ColeLeaderCredentials
Consensus.coleLeaderCredentials = Maybe ColeLeaderCredentials
forall a. Maybe a
Nothing
            , $sel:coleMaxTxCapacityOverrides:ProtocolParamsCole :: Overrides ColeBlock
Consensus.coleMaxTxCapacityOverrides = TxMeasure ColeBlock -> Overrides ColeBlock
forall blk. TxMeasure blk -> Overrides blk
TxLimits.mkOverrides TxMeasure ColeBlock
forall a. BoundedMeasure a => a
TxLimits.noOverridesMeasure
            }
          ProtocolParamsSophieBased :: forall era.
SophieGenesis era
-> Nonce
-> [TOptimumLeaderCredentials (EraCrypto era)]
-> ProtocolParamsSophieBased era
Consensus.ProtocolParamsSophieBased
            { $sel:sophieBasedGenesis:ProtocolParamsSophieBased :: SophieGenesis (SophieEra StandardCrypto)
Consensus.sophieBasedGenesis = SophieConfig -> SophieGenesis (SophieEra StandardCrypto)
scConfig SophieConfig
sophieGenesis
            , $sel:sophieBasedInitialNonce:ProtocolParamsSophieBased :: Nonce
Consensus.sophieBasedInitialNonce = SophieConfig -> Nonce
sophieOptimumNonce SophieConfig
sophieGenesis
            , $sel:sophieBasedLeaderCredentials:ProtocolParamsSophieBased :: [TOptimumLeaderCredentials (EraCrypto (SophieEra StandardCrypto))]
Consensus.sophieBasedLeaderCredentials = []
            }
          ProtocolParamsSophie :: forall c.
ProtVer
-> Overrides (SophieBlock (SophieEra c)) -> ProtocolParamsSophie c
Consensus.ProtocolParamsSophie
            { $sel:sophieProtVer:ProtocolParamsSophie :: ProtVer
Consensus.sophieProtVer = NodeConfig -> ProtVer
sophieProtVer NodeConfig
dnc
            , $sel:sophieMaxTxCapacityOverrides:ProtocolParamsSophie :: Overrides (SophieBlock (SophieEra StandardCrypto))
Consensus.sophieMaxTxCapacityOverrides = TxMeasure (SophieBlock (SophieEra StandardCrypto))
-> Overrides (SophieBlock (SophieEra StandardCrypto))
forall blk. TxMeasure blk -> Overrides blk
TxLimits.mkOverrides TxMeasure (SophieBlock (SophieEra StandardCrypto))
forall a. BoundedMeasure a => a
TxLimits.noOverridesMeasure
            }
          ProtocolParamsEvie :: forall c.
ProtVer
-> Overrides (SophieBlock (EvieEra c)) -> ProtocolParamsEvie c
Consensus.ProtocolParamsEvie
            { $sel:evieProtVer:ProtocolParamsEvie :: ProtVer
Consensus.evieProtVer = NodeConfig -> ProtVer
sophieProtVer NodeConfig
dnc
            , $sel:evieMaxTxCapacityOverrides:ProtocolParamsEvie :: Overrides (SophieBlock (EvieEra StandardCrypto))
Consensus.evieMaxTxCapacityOverrides = TxMeasure (SophieBlock (EvieEra StandardCrypto))
-> Overrides (SophieBlock (EvieEra StandardCrypto))
forall blk. TxMeasure blk -> Overrides blk
TxLimits.mkOverrides TxMeasure (SophieBlock (EvieEra StandardCrypto))
forall a. BoundedMeasure a => a
TxLimits.noOverridesMeasure
            }
          ProtocolParamsJen :: forall c.
ProtVer
-> Overrides (SophieBlock (JenEra c)) -> ProtocolParamsJen c
Consensus.ProtocolParamsJen
            { $sel:jenProtVer:ProtocolParamsJen :: ProtVer
Consensus.jenProtVer = NodeConfig -> ProtVer
sophieProtVer NodeConfig
dnc
            , $sel:jenMaxTxCapacityOverrides:ProtocolParamsJen :: Overrides (SophieBlock (JenEra StandardCrypto))
Consensus.jenMaxTxCapacityOverrides = TxMeasure (SophieBlock (JenEra StandardCrypto))
-> Overrides (SophieBlock (JenEra StandardCrypto))
forall blk. TxMeasure blk -> Overrides blk
TxLimits.mkOverrides TxMeasure (SophieBlock (JenEra StandardCrypto))
forall a. BoundedMeasure a => a
TxLimits.noOverridesMeasure
            }
          ProtocolParamsAurum :: forall c.
ProtVer
-> Overrides (SophieBlock (AurumEra c)) -> ProtocolParamsAurum c
Consensus.ProtocolParamsAurum
            { $sel:aurumProtVer:ProtocolParamsAurum :: ProtVer
Consensus.aurumProtVer = NodeConfig -> ProtVer
sophieProtVer NodeConfig
dnc
            , $sel:aurumMaxTxCapacityOverrides:ProtocolParamsAurum :: Overrides (SophieBlock (AurumEra StandardCrypto))
Consensus.aurumMaxTxCapacityOverrides  = TxMeasure (SophieBlock (AurumEra StandardCrypto))
-> Overrides (SophieBlock (AurumEra StandardCrypto))
forall blk. TxMeasure blk -> Overrides blk
TxLimits.mkOverrides TxMeasure (SophieBlock (AurumEra StandardCrypto))
forall a. BoundedMeasure a => a
TxLimits.noOverridesMeasure
            }
          (NodeConfig
-> ProtocolTransitionParamsSophieBased (SophieEra StandardCrypto)
ncColeToSophie NodeConfig
dnc)
          (NodeConfig
-> ProtocolTransitionParamsSophieBased (EvieEra StandardCrypto)
ncSophieToEvie NodeConfig
dnc)
          (NodeConfig
-> ProtocolTransitionParamsSophieBased (JenEra StandardCrypto)
ncEvieToJen NodeConfig
dnc)
          (TranslationContext (AurumEra StandardCrypto)
-> TriggerHardFork
-> ProtocolTransitionParamsSophieBased (AurumEra StandardCrypto)
forall era.
TranslationContext era
-> TriggerHardFork -> ProtocolTransitionParamsSophieBased era
Consensus.ProtocolTransitionParamsSophieBased AurumGenesis
TranslationContext (AurumEra StandardCrypto)
aurumGenesis (NodeConfig -> TriggerHardFork
ncJenToAurum NodeConfig
dnc))

sophieOptimumNonce :: SophieConfig -> Sophie.Spec.Nonce
sophieOptimumNonce :: SophieConfig -> Nonce
sophieOptimumNonce SophieConfig
sCfg = Hash Blake2b_256 Nonce -> Nonce
Sophie.Spec.Nonce (Hash Blake2b_256 ByteString -> Hash Blake2b_256 Nonce
forall h a b. Hash h a -> Hash h b
Bcc.Crypto.Hash.Class.castHash (Hash Blake2b_256 ByteString -> Hash Blake2b_256 Nonce)
-> (GenesisHashSophie -> Hash Blake2b_256 ByteString)
-> GenesisHashSophie
-> Hash Blake2b_256 Nonce
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenesisHashSophie -> Hash Blake2b_256 ByteString
unGenesisHashSophie (GenesisHashSophie -> Hash Blake2b_256 Nonce)
-> GenesisHashSophie -> Hash Blake2b_256 Nonce
forall a b. (a -> b) -> a -> b
$ SophieConfig -> GenesisHashSophie
scGenesisHash SophieConfig
sCfg)

sophieProtVer :: NodeConfig -> Sophie.Spec.ProtVer
sophieProtVer :: NodeConfig -> ProtVer
sophieProtVer NodeConfig
dnc =
  let bver :: ProtocolVersion
bver = NodeConfig -> ProtocolVersion
ncColeProtocolVersion NodeConfig
dnc in
  Natural -> Natural -> ProtVer
Sophie.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
Bcc.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
Bcc.Chain.Update.pvSentry ProtocolVersion
bver)

readBccGenesisConfig
        :: NodeConfig
        -> ExceptT GenesisConfigError IO GenesisConfig
readBccGenesisConfig :: NodeConfig -> ExceptT GenesisConfigError IO GenesisConfig
readBccGenesisConfig NodeConfig
enc =
  NodeConfig
-> Config -> SophieConfig -> AurumGenesis -> GenesisConfig
GenesisBcc NodeConfig
enc
    (Config -> SophieConfig -> AurumGenesis -> GenesisConfig)
-> ExceptT GenesisConfigError IO Config
-> ExceptT
     GenesisConfigError
     IO
     (SophieConfig -> AurumGenesis -> GenesisConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeConfig -> ExceptT GenesisConfigError IO Config
readColeGenesisConfig NodeConfig
enc
    ExceptT
  GenesisConfigError
  IO
  (SophieConfig -> AurumGenesis -> GenesisConfig)
-> ExceptT GenesisConfigError IO SophieConfig
-> ExceptT GenesisConfigError IO (AurumGenesis -> GenesisConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NodeConfig -> ExceptT GenesisConfigError IO SophieConfig
readSophieGenesisConfig NodeConfig
enc
    ExceptT GenesisConfigError IO (AurumGenesis -> GenesisConfig)
-> ExceptT GenesisConfigError IO AurumGenesis
-> ExceptT GenesisConfigError IO GenesisConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NodeConfig -> ExceptT GenesisConfigError IO AurumGenesis
readAurumGenesisConfig NodeConfig
enc

data GenesisConfigError
  = NEError !Text
  | NEColeConfig !FilePath !Bcc.Chain.Genesis.ConfigurationError
  | NESophieConfig !FilePath !Text
  | NEAurumConfig !FilePath !Text
  | NEBccConfig !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
    NEColeConfig FilePath
fp ConfigurationError
ce ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Failed reading Cole genesis file ", FilePath -> Text
forall a. Show a => a -> Text
textShow FilePath
fp, Text
": ", ConfigurationError -> Text
forall a. Show a => a -> Text
textShow ConfigurationError
ce
        ]
    NESophieConfig FilePath
fp Text
txt ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Failed reading Sophie genesis file ", FilePath -> Text
forall a. Show a => a -> Text
textShow FilePath
fp, Text
": ", Text
txt
        ]
    NEAurumConfig FilePath
fp Text
txt ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Failed reading Aurum genesis file ", FilePath -> Text
forall a. Show a => a -> Text
textShow FilePath
fp, Text
": ", Text
txt
        ]
    NEBccConfig Text
err ->
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"With Bcc protocol, Cole/Sophie 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 -> FilePath -> FilePath
[LookupFail] -> FilePath -> FilePath
LookupFail -> FilePath
(Int -> LookupFail -> FilePath -> FilePath)
-> (LookupFail -> FilePath)
-> ([LookupFail] -> FilePath -> FilePath)
-> Show LookupFail
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [LookupFail] -> FilePath -> FilePath
$cshowList :: [LookupFail] -> FilePath -> FilePath
show :: LookupFail -> FilePath
$cshow :: LookupFail -> FilePath
showsPrec :: Int -> LookupFail -> FilePath -> FilePath
$cshowsPrec :: Int -> LookupFail -> FilePath -> FilePath
Show)

readColeGenesisConfig
        :: NodeConfig
        -> ExceptT GenesisConfigError IO Bcc.Chain.Genesis.Config
readColeGenesisConfig :: NodeConfig -> ExceptT GenesisConfigError IO Config
readColeGenesisConfig NodeConfig
enc = do
  let file :: FilePath
file = GenesisFile -> FilePath
unGenesisFile (GenesisFile -> FilePath) -> GenesisFile -> FilePath
forall a b. (a -> b) -> a -> b
$ NodeConfig -> GenesisFile
ncColeGenesisFile 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)
Bcc.Crypto.Hashing.decodeAbstractHash (GenesisHashCole -> Text
unGenesisHashCole (GenesisHashCole -> Text) -> GenesisHashCole -> Text
forall a b. (a -> b) -> a -> b
$ NodeConfig -> GenesisHashCole
ncColeGenesisHash 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 (FilePath -> ConfigurationError -> GenesisConfigError
NEColeConfig FilePath
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
-> FilePath
-> AbstractHash Blake2b_256 Raw
-> ExceptT ConfigurationError IO Config
forall (m :: * -> *).
(MonadError ConfigurationError m, MonadIO m) =>
RequiresNetworkMagic
-> FilePath -> AbstractHash Blake2b_256 Raw -> m Config
Bcc.Chain.Genesis.mkConfigFromFile (NodeConfig -> RequiresNetworkMagic
ncRequiresNetworkMagic NodeConfig
enc) FilePath
file AbstractHash Blake2b_256 Raw
genHash

readSophieGenesisConfig
    :: NodeConfig
    -> ExceptT GenesisConfigError IO SophieConfig
readSophieGenesisConfig :: NodeConfig -> ExceptT GenesisConfigError IO SophieConfig
readSophieGenesisConfig NodeConfig
enc = do
  let file :: FilePath
file = GenesisFile -> FilePath
unGenesisFile (GenesisFile -> FilePath) -> GenesisFile -> FilePath
forall a b. (a -> b) -> a -> b
$ NodeConfig -> GenesisFile
ncSophieGenesisFile NodeConfig
enc
  (SophieGenesisError -> GenesisConfigError)
-> ExceptT SophieGenesisError IO SophieConfig
-> ExceptT GenesisConfigError IO SophieConfig
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT (FilePath -> Text -> GenesisConfigError
NESophieConfig FilePath
file (Text -> GenesisConfigError)
-> (SophieGenesisError -> Text)
-> SophieGenesisError
-> GenesisConfigError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SophieGenesisError -> Text
renderSophieGenesisError)
    (ExceptT SophieGenesisError IO SophieConfig
 -> ExceptT GenesisConfigError IO SophieConfig)
-> ExceptT SophieGenesisError IO SophieConfig
-> ExceptT GenesisConfigError IO SophieConfig
forall a b. (a -> b) -> a -> b
$ GenesisFile
-> GenesisHashSophie -> ExceptT SophieGenesisError IO SophieConfig
readSophieGenesis (FilePath -> GenesisFile
GenesisFile FilePath
file) (NodeConfig -> GenesisHashSophie
ncSophieGenesisHash NodeConfig
enc)

readAurumGenesisConfig
    :: NodeConfig
    -> ExceptT GenesisConfigError IO AurumGenesis
readAurumGenesisConfig :: NodeConfig -> ExceptT GenesisConfigError IO AurumGenesis
readAurumGenesisConfig NodeConfig
enc = do
  let file :: FilePath
file = GenesisFile -> FilePath
unGenesisFile (GenesisFile -> FilePath) -> GenesisFile -> FilePath
forall a b. (a -> b) -> a -> b
$ NodeConfig -> GenesisFile
ncAurumGenesisFile NodeConfig
enc
  (AurumGenesisError -> GenesisConfigError)
-> ExceptT AurumGenesisError IO AurumGenesis
-> ExceptT GenesisConfigError IO AurumGenesis
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT (FilePath -> Text -> GenesisConfigError
NEAurumConfig FilePath
file (Text -> GenesisConfigError)
-> (AurumGenesisError -> Text)
-> AurumGenesisError
-> GenesisConfigError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AurumGenesisError -> Text
renderAurumGenesisError)
    (ExceptT AurumGenesisError IO AurumGenesis
 -> ExceptT GenesisConfigError IO AurumGenesis)
-> ExceptT AurumGenesisError IO AurumGenesis
-> ExceptT GenesisConfigError IO AurumGenesis
forall a b. (a -> b) -> a -> b
$ GenesisFile
-> GenesisHashAurum -> ExceptT AurumGenesisError IO AurumGenesis
readAurumGenesis (FilePath -> GenesisFile
GenesisFile FilePath
file) (NodeConfig -> GenesisHashAurum
ncAurumGenesisHash NodeConfig
enc)

textShow :: Show a => a -> Text
textShow :: a -> Text
textShow = FilePath -> Text
Text.pack (FilePath -> Text) -> (a -> FilePath) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall a. Show a => a -> FilePath
show

readSophieGenesis
    :: GenesisFile -> GenesisHashSophie
    -> ExceptT SophieGenesisError IO SophieConfig
readSophieGenesis :: GenesisFile
-> GenesisHashSophie -> ExceptT SophieGenesisError IO SophieConfig
readSophieGenesis (GenesisFile FilePath
file) GenesisHashSophie
expectedGenesisHash = do
    ByteString
content <- (IOException -> SophieGenesisError)
-> IO ByteString -> ExceptT SophieGenesisError IO ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FilePath -> Text -> SophieGenesisError
SophieGenesisReadError FilePath
file (Text -> SophieGenesisError)
-> (IOException -> Text) -> IOException -> SophieGenesisError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> Text
forall a. Show a => a -> Text
textShow) (IO ByteString -> ExceptT SophieGenesisError IO ByteString)
-> IO ByteString -> ExceptT SophieGenesisError IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
BS.readFile FilePath
file
    let genesisHash :: GenesisHashSophie
genesisHash = Hash Blake2b_256 ByteString -> GenesisHashSophie
GenesisHashSophie ((ByteString -> ByteString)
-> ByteString -> Hash Blake2b_256 ByteString
forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Bcc.Crypto.Hash.Class.hashWith ByteString -> ByteString
forall a. a -> a
id ByteString
content)
    GenesisHashSophie -> ExceptT SophieGenesisError IO ()
checkExpectedGenesisHash GenesisHashSophie
genesisHash
    SophieGenesis (SophieEra StandardCrypto)
genesis <- (FilePath -> SophieGenesisError)
-> ExceptT FilePath IO (SophieGenesis (SophieEra StandardCrypto))
-> ExceptT
     SophieGenesisError IO (SophieGenesis (SophieEra StandardCrypto))
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT (FilePath -> Text -> SophieGenesisError
SophieGenesisDecodeError FilePath
file (Text -> SophieGenesisError)
-> (FilePath -> Text) -> FilePath -> SophieGenesisError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack)
                  (ExceptT FilePath IO (SophieGenesis (SophieEra StandardCrypto))
 -> ExceptT
      SophieGenesisError IO (SophieGenesis (SophieEra StandardCrypto)))
-> (Either FilePath (SophieGenesis (SophieEra StandardCrypto))
    -> ExceptT FilePath IO (SophieGenesis (SophieEra StandardCrypto)))
-> Either FilePath (SophieGenesis (SophieEra StandardCrypto))
-> ExceptT
     SophieGenesisError IO (SophieGenesis (SophieEra StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either FilePath (SophieGenesis (SophieEra StandardCrypto))
-> ExceptT FilePath IO (SophieGenesis (SophieEra StandardCrypto))
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither
                  (Either FilePath (SophieGenesis (SophieEra StandardCrypto))
 -> ExceptT
      SophieGenesisError IO (SophieGenesis (SophieEra StandardCrypto)))
-> Either FilePath (SophieGenesis (SophieEra StandardCrypto))
-> ExceptT
     SophieGenesisError IO (SophieGenesis (SophieEra StandardCrypto))
forall a b. (a -> b) -> a -> b
$ ByteString
-> Either FilePath (SophieGenesis (SophieEra StandardCrypto))
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecodeStrict' ByteString
content
    SophieConfig -> ExceptT SophieGenesisError IO SophieConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SophieConfig -> ExceptT SophieGenesisError IO SophieConfig)
-> SophieConfig -> ExceptT SophieGenesisError IO SophieConfig
forall a b. (a -> b) -> a -> b
$ SophieGenesis (SophieEra StandardCrypto)
-> GenesisHashSophie -> SophieConfig
SophieConfig SophieGenesis (SophieEra StandardCrypto)
genesis GenesisHashSophie
genesisHash
  where
    checkExpectedGenesisHash :: GenesisHashSophie -> ExceptT SophieGenesisError IO ()
    checkExpectedGenesisHash :: GenesisHashSophie -> ExceptT SophieGenesisError IO ()
checkExpectedGenesisHash GenesisHashSophie
actual =
      if GenesisHashSophie
actual GenesisHashSophie -> GenesisHashSophie -> Bool
forall a. Eq a => a -> a -> Bool
/= GenesisHashSophie
expectedGenesisHash
        then SophieGenesisError -> ExceptT SophieGenesisError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
left (GenesisHashSophie -> GenesisHashSophie -> SophieGenesisError
SophieGenesisHashMismatch GenesisHashSophie
actual GenesisHashSophie
expectedGenesisHash)
        else () -> ExceptT SophieGenesisError IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

data SophieGenesisError
     = SophieGenesisReadError !FilePath !Text
     | SophieGenesisHashMismatch !GenesisHashSophie !GenesisHashSophie -- actual, expected
     | SophieGenesisDecodeError !FilePath !Text
     deriving Int -> SophieGenesisError -> FilePath -> FilePath
[SophieGenesisError] -> FilePath -> FilePath
SophieGenesisError -> FilePath
(Int -> SophieGenesisError -> FilePath -> FilePath)
-> (SophieGenesisError -> FilePath)
-> ([SophieGenesisError] -> FilePath -> FilePath)
-> Show SophieGenesisError
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [SophieGenesisError] -> FilePath -> FilePath
$cshowList :: [SophieGenesisError] -> FilePath -> FilePath
show :: SophieGenesisError -> FilePath
$cshow :: SophieGenesisError -> FilePath
showsPrec :: Int -> SophieGenesisError -> FilePath -> FilePath
$cshowsPrec :: Int -> SophieGenesisError -> FilePath -> FilePath
Show

renderSophieGenesisError :: SophieGenesisError -> Text
renderSophieGenesisError :: SophieGenesisError -> Text
renderSophieGenesisError SophieGenesisError
sge =
    case SophieGenesisError
sge of
      SophieGenesisReadError FilePath
fp Text
err ->
        [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
          [ Text
"There was an error reading the genesis file: ", FilePath -> Text
Text.pack FilePath
fp
          , Text
" Error: ", Text
err
          ]

      SophieGenesisHashMismatch GenesisHashSophie
actual GenesisHashSophie
expected ->
        [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
          [ Text
"Wrong Sophie genesis file: the actual hash is ", Hash Blake2b_256 ByteString -> Text
renderHash (GenesisHashSophie -> Hash Blake2b_256 ByteString
unGenesisHashSophie GenesisHashSophie
actual)
          , Text
", but the expected Sophie genesis hash given in the node "
          , Text
"configuration file is ", Hash Blake2b_256 ByteString -> Text
renderHash (GenesisHashSophie -> Hash Blake2b_256 ByteString
unGenesisHashSophie GenesisHashSophie
expected), Text
"."
          ]

      SophieGenesisDecodeError FilePath
fp Text
err ->
        [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
          [ Text
"There was an error parsing the genesis file: ", FilePath -> Text
Text.pack FilePath
fp
          , Text
" Error: ", Text
err
          ]

readAurumGenesis
    :: GenesisFile -> GenesisHashAurum
    -> ExceptT AurumGenesisError IO AurumGenesis
readAurumGenesis :: GenesisFile
-> GenesisHashAurum -> ExceptT AurumGenesisError IO AurumGenesis
readAurumGenesis (GenesisFile FilePath
file) GenesisHashAurum
expectedGenesisHash = do
    ByteString
content <- (IOException -> AurumGenesisError)
-> IO ByteString -> ExceptT AurumGenesisError IO ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FilePath -> Text -> AurumGenesisError
AurumGenesisReadError FilePath
file (Text -> AurumGenesisError)
-> (IOException -> Text) -> IOException -> AurumGenesisError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> Text
forall a. Show a => a -> Text
textShow) (IO ByteString -> ExceptT AurumGenesisError IO ByteString)
-> IO ByteString -> ExceptT AurumGenesisError IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
BS.readFile FilePath
file
    let genesisHash :: GenesisHashAurum
genesisHash = Hash Blake2b_256 ByteString -> GenesisHashAurum
GenesisHashAurum ((ByteString -> ByteString)
-> ByteString -> Hash Blake2b_256 ByteString
forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Bcc.Crypto.Hash.Class.hashWith ByteString -> ByteString
forall a. a -> a
id ByteString
content)
    GenesisHashAurum -> ExceptT AurumGenesisError IO ()
checkExpectedGenesisHash GenesisHashAurum
genesisHash
    (FilePath -> AurumGenesisError)
-> ExceptT FilePath IO AurumGenesis
-> ExceptT AurumGenesisError IO AurumGenesis
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT (FilePath -> Text -> AurumGenesisError
AurumGenesisDecodeError FilePath
file (Text -> AurumGenesisError)
-> (FilePath -> Text) -> FilePath -> AurumGenesisError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack)
                  (ExceptT FilePath IO AurumGenesis
 -> ExceptT AurumGenesisError IO AurumGenesis)
-> (Either FilePath AurumGenesis
    -> ExceptT FilePath IO AurumGenesis)
-> Either FilePath AurumGenesis
-> ExceptT AurumGenesisError IO AurumGenesis
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either FilePath AurumGenesis -> ExceptT FilePath IO AurumGenesis
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither
                  (Either FilePath AurumGenesis
 -> ExceptT AurumGenesisError IO AurumGenesis)
-> Either FilePath AurumGenesis
-> ExceptT AurumGenesisError IO AurumGenesis
forall a b. (a -> b) -> a -> b
$ ByteString -> Either FilePath AurumGenesis
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecodeStrict' ByteString
content
  where
    checkExpectedGenesisHash :: GenesisHashAurum -> ExceptT AurumGenesisError IO ()
    checkExpectedGenesisHash :: GenesisHashAurum -> ExceptT AurumGenesisError IO ()
checkExpectedGenesisHash GenesisHashAurum
actual =
      if GenesisHashAurum
actual GenesisHashAurum -> GenesisHashAurum -> Bool
forall a. Eq a => a -> a -> Bool
/= GenesisHashAurum
expectedGenesisHash
        then AurumGenesisError -> ExceptT AurumGenesisError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
left (GenesisHashAurum -> GenesisHashAurum -> AurumGenesisError
AurumGenesisHashMismatch GenesisHashAurum
actual GenesisHashAurum
expectedGenesisHash)
        else () -> ExceptT AurumGenesisError IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

data AurumGenesisError
     = AurumGenesisReadError !FilePath !Text
     | AurumGenesisHashMismatch !GenesisHashAurum !GenesisHashAurum -- actual, expected
     | AurumGenesisDecodeError !FilePath !Text
     deriving Int -> AurumGenesisError -> FilePath -> FilePath
[AurumGenesisError] -> FilePath -> FilePath
AurumGenesisError -> FilePath
(Int -> AurumGenesisError -> FilePath -> FilePath)
-> (AurumGenesisError -> FilePath)
-> ([AurumGenesisError] -> FilePath -> FilePath)
-> Show AurumGenesisError
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [AurumGenesisError] -> FilePath -> FilePath
$cshowList :: [AurumGenesisError] -> FilePath -> FilePath
show :: AurumGenesisError -> FilePath
$cshow :: AurumGenesisError -> FilePath
showsPrec :: Int -> AurumGenesisError -> FilePath -> FilePath
$cshowsPrec :: Int -> AurumGenesisError -> FilePath -> FilePath
Show

renderAurumGenesisError :: AurumGenesisError -> Text
renderAurumGenesisError :: AurumGenesisError -> Text
renderAurumGenesisError AurumGenesisError
sge =
    case AurumGenesisError
sge of
      AurumGenesisReadError FilePath
fp Text
err ->
        [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
          [ Text
"There was an error reading the genesis file: ", FilePath -> Text
Text.pack FilePath
fp
          , Text
" Error: ", Text
err
          ]

      AurumGenesisHashMismatch GenesisHashAurum
actual GenesisHashAurum
expected ->
        [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
          [ Text
"Wrong Aurum genesis file: the actual hash is ", Hash Blake2b_256 ByteString -> Text
renderHash (GenesisHashAurum -> Hash Blake2b_256 ByteString
unGenesisHashAurum GenesisHashAurum
actual)
          , Text
", but the expected Aurum genesis hash given in the node "
          , Text
"configuration file is ", Hash Blake2b_256 ByteString -> Text
renderHash (GenesisHashAurum -> Hash Blake2b_256 ByteString
unGenesisHashAurum GenesisHashAurum
expected), Text
"."
          ]

      AurumGenesisDecodeError FilePath
fp Text
err ->
        [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
          [ Text
"There was an error parsing the genesis file: ", FilePath -> Text
Text.pack FilePath
fp
          , Text
" Error: ", Text
err
          ]

renderHash :: Bcc.Crypto.Hash.Class.Hash Bcc.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
Bcc.Crypto.Hash.Class.hashToBytes Hash Blake2b_256 ByteString
h)

newtype StakeCred
  = StakeCred { StakeCred -> Credential 'Staking StandardCrypto
_unStakeCred :: Sophie.Spec.Credential 'Sophie.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 (BccEras StandardCrypto)
envLedgerConfig :: HFC.HardForkLedgerConfig (Consensus.BccEras Sophie.StandardCrypto)
  , Env -> ConsensusConfig (HardForkProtocol (BccEras StandardCrypto))
envProtocolConfig :: Sophie.ConsensusConfig (HFC.HardForkProtocol (Consensus.BccEras Sophie.StandardCrypto))
  }

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

applyBlockWithEvents
  :: Env
  -> LedgerState
  -> Bool
  -- ^ True to validate
  ->  HFC.HardForkBlock
            (Consensus.BccEras Consensus.StandardCrypto)
  -> Either Text LedgerStateEvents
applyBlockWithEvents :: Env
-> LedgerState
-> Bool
-> HardForkBlock (BccEras StandardCrypto)
-> Either Text LedgerStateEvents
applyBlockWithEvents Env
env LedgerState
oldState Bool
enableValidation HardForkBlock (BccEras StandardCrypto)
block = do
  let config :: HardForkLedgerConfig (BccEras StandardCrypto)
config = Env -> HardForkLedgerConfig (BccEras StandardCrypto)
envLedgerConfig Env
env
      stateOld :: LedgerState (HardForkBlock (BccEras StandardCrypto))
stateOld = LedgerState -> LedgerState (HardForkBlock (BccEras StandardCrypto))
clsState LedgerState
oldState
  if Bool
enableValidation
    then HardForkLedgerConfig (BccEras StandardCrypto)
-> HardForkBlock (BccEras StandardCrypto)
-> LedgerState (HardForkBlock (BccEras StandardCrypto))
-> Either Text LedgerStateEvents
tickThenApply HardForkLedgerConfig (BccEras StandardCrypto)
config HardForkBlock (BccEras StandardCrypto)
block LedgerState (HardForkBlock (BccEras StandardCrypto))
stateOld
    else HardForkLedgerConfig (BccEras StandardCrypto)
-> HardForkBlock (BccEras StandardCrypto)
-> LedgerState (HardForkBlock (BccEras StandardCrypto))
-> Either Text LedgerStateEvents
tickThenReapplyCheckHash HardForkLedgerConfig (BccEras StandardCrypto)
config HardForkBlock (BccEras StandardCrypto)
block LedgerState (HardForkBlock (BccEras 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.BccEras Sophie.StandardCrypto)
    -> Consensus.BccBlock Consensus.StandardCrypto
    -> Sophie.LedgerState
        (HFC.HardForkBlock
            (Consensus.BccEras Sophie.StandardCrypto))
    -> Either Text LedgerStateEvents
tickThenReapplyCheckHash :: HardForkLedgerConfig (BccEras StandardCrypto)
-> HardForkBlock (BccEras StandardCrypto)
-> LedgerState (HardForkBlock (BccEras StandardCrypto))
-> Either Text LedgerStateEvents
tickThenReapplyCheckHash HardForkLedgerConfig (BccEras StandardCrypto)
cfg HardForkBlock (BccEras StandardCrypto)
block LedgerState (HardForkBlock (BccEras StandardCrypto))
lsb =
  if HardForkBlock (BccEras StandardCrypto)
-> ChainHash (HardForkBlock (BccEras StandardCrypto))
forall blk. GetPrevHash blk => blk -> ChainHash blk
Consensus.blockPrevHash HardForkBlock (BccEras StandardCrypto)
block ChainHash (HardForkBlock (BccEras StandardCrypto))
-> ChainHash (HardForkBlock (BccEras StandardCrypto)) -> Bool
forall a. Eq a => a -> a -> Bool
== LedgerState (HardForkBlock (BccEras StandardCrypto))
-> ChainHash (HardForkBlock (BccEras StandardCrypto))
forall blk. UpdateLedger blk => LedgerState blk -> ChainHash blk
Ledger.ledgerTipHash LedgerState (HardForkBlock (BccEras StandardCrypto))
lsb
    then LedgerStateEvents -> Either Text LedgerStateEvents
forall a b. b -> Either a b
Right (LedgerStateEvents -> Either Text LedgerStateEvents)
-> (LedgerResult
      (LedgerState (HardForkBlock (BccEras StandardCrypto)))
      (LedgerState (HardForkBlock (BccEras StandardCrypto)))
    -> LedgerStateEvents)
-> LedgerResult
     (LedgerState (HardForkBlock (BccEras StandardCrypto)))
     (LedgerState (HardForkBlock (BccEras StandardCrypto)))
-> Either Text LedgerStateEvents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerResult
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
-> LedgerStateEvents
toLedgerStateEvents
          (LedgerResult
   (LedgerState (HardForkBlock (BccEras StandardCrypto)))
   (LedgerState (HardForkBlock (BccEras StandardCrypto)))
 -> Either Text LedgerStateEvents)
-> LedgerResult
     (LedgerState (HardForkBlock (BccEras StandardCrypto)))
     (LedgerState (HardForkBlock (BccEras StandardCrypto)))
-> Either Text LedgerStateEvents
forall a b. (a -> b) -> a -> b
$ LedgerConfig (HardForkBlock (BccEras StandardCrypto))
-> HardForkBlock (BccEras StandardCrypto)
-> LedgerState (HardForkBlock (BccEras StandardCrypto))
-> LedgerResult
     (LedgerState (HardForkBlock (BccEras StandardCrypto)))
     (LedgerState (HardForkBlock (BccEras StandardCrypto)))
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> LedgerResult l l
Ledger.tickThenReapplyLedgerResult LedgerConfig (HardForkBlock (BccEras StandardCrypto))
HardForkLedgerConfig (BccEras StandardCrypto)
cfg HardForkBlock (BccEras StandardCrypto)
block LedgerState (HardForkBlock (BccEras StandardCrypto))
lsb
    else Text -> Either Text LedgerStateEvents
forall a b. a -> Either a b
Left (Text -> Either Text LedgerStateEvents)
-> Text -> Either Text LedgerStateEvents
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 (BccEras StandardCrypto))
-> WithOrigin SlotNo
forall blk.
UpdateLedger blk =>
LedgerState blk -> WithOrigin SlotNo
Ledger.ledgerTipSlot LedgerState (HardForkBlock (BccEras 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 (BccEras StandardCrypto)) -> ByteString
forall era. ChainHash (BccBlock era) -> ByteString
unChainHash
                      (ChainHash (HardForkBlock (BccEras StandardCrypto)) -> ByteString)
-> ChainHash (HardForkBlock (BccEras StandardCrypto)) -> ByteString
forall a b. (a -> b) -> a -> b
$ LedgerState (HardForkBlock (BccEras StandardCrypto))
-> ChainHash (HardForkBlock (BccEras StandardCrypto))
forall blk. UpdateLedger blk => LedgerState blk -> ChainHash blk
Ledger.ledgerTipHash LedgerState (HardForkBlock (BccEras StandardCrypto))
lsb
                  , Text
" but block previous hash is "
                  , ByteString -> Text
forall bin. ByteArrayAccess bin => bin -> Text
renderByteArray (ChainHash (HardForkBlock (BccEras StandardCrypto)) -> ByteString
forall era. ChainHash (BccBlock era) -> ByteString
unChainHash (ChainHash (HardForkBlock (BccEras StandardCrypto)) -> ByteString)
-> ChainHash (HardForkBlock (BccEras StandardCrypto)) -> ByteString
forall a b. (a -> b) -> a -> b
$ HardForkBlock (BccEras StandardCrypto)
-> ChainHash (HardForkBlock (BccEras StandardCrypto))
forall blk. GetPrevHash blk => blk -> ChainHash blk
Consensus.blockPrevHash HardForkBlock (BccEras 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 (BccEras StandardCrypto) -> ShortByteString
forall k (xs :: [k]). OneEraHash xs -> ShortByteString
HFC.getOneEraHash
                      (OneEraHash (BccEras StandardCrypto) -> ShortByteString)
-> OneEraHash (BccEras StandardCrypto) -> ShortByteString
forall a b. (a -> b) -> a -> b
$ HardForkBlock (BccEras StandardCrypto)
-> HeaderHash (HardForkBlock (BccEras StandardCrypto))
forall b. HasHeader b => b -> HeaderHash b
Shardagnostic.Network.Block.blockHash HardForkBlock (BccEras 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.BccEras Sophie.StandardCrypto)
    -> Consensus.BccBlock Consensus.StandardCrypto
    -> Sophie.LedgerState
        (HFC.HardForkBlock
            (Consensus.BccEras Sophie.StandardCrypto))
    -> Either Text LedgerStateEvents
tickThenApply :: HardForkLedgerConfig (BccEras StandardCrypto)
-> HardForkBlock (BccEras StandardCrypto)
-> LedgerState (HardForkBlock (BccEras StandardCrypto))
-> Either Text LedgerStateEvents
tickThenApply HardForkLedgerConfig (BccEras StandardCrypto)
cfg HardForkBlock (BccEras StandardCrypto)
block LedgerState (HardForkBlock (BccEras StandardCrypto))
lsb
  = (HardForkLedgerError (BccEras StandardCrypto)
 -> Either Text LedgerStateEvents)
-> (LedgerResult
      (LedgerState (HardForkBlock (BccEras StandardCrypto)))
      (LedgerState (HardForkBlock (BccEras StandardCrypto)))
    -> Either Text LedgerStateEvents)
-> Either
     (HardForkLedgerError (BccEras StandardCrypto))
     (LedgerResult
        (LedgerState (HardForkBlock (BccEras StandardCrypto)))
        (LedgerState (HardForkBlock (BccEras StandardCrypto))))
-> Either Text LedgerStateEvents
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Either Text LedgerStateEvents
forall a b. a -> Either a b
Left (Text -> Either Text LedgerStateEvents)
-> (HardForkLedgerError (BccEras StandardCrypto) -> Text)
-> HardForkLedgerError (BccEras StandardCrypto)
-> Either Text LedgerStateEvents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack (FilePath -> Text)
-> (HardForkLedgerError (BccEras StandardCrypto) -> FilePath)
-> HardForkLedgerError (BccEras StandardCrypto)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkLedgerError (BccEras StandardCrypto) -> FilePath
forall a. Show a => a -> FilePath
show) (LedgerStateEvents -> Either Text LedgerStateEvents
forall a b. b -> Either a b
Right (LedgerStateEvents -> Either Text LedgerStateEvents)
-> (LedgerResult
      (LedgerState (HardForkBlock (BccEras StandardCrypto)))
      (LedgerState (HardForkBlock (BccEras StandardCrypto)))
    -> LedgerStateEvents)
-> LedgerResult
     (LedgerState (HardForkBlock (BccEras StandardCrypto)))
     (LedgerState (HardForkBlock (BccEras StandardCrypto)))
-> Either Text LedgerStateEvents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerResult
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
  (LedgerState (HardForkBlock (BccEras StandardCrypto)))
-> LedgerStateEvents
toLedgerStateEvents)
  (Either
   (HardForkLedgerError (BccEras StandardCrypto))
   (LedgerResult
      (LedgerState (HardForkBlock (BccEras StandardCrypto)))
      (LedgerState (HardForkBlock (BccEras StandardCrypto))))
 -> Either Text LedgerStateEvents)
-> Either
     (HardForkLedgerError (BccEras StandardCrypto))
     (LedgerResult
        (LedgerState (HardForkBlock (BccEras StandardCrypto)))
        (LedgerState (HardForkBlock (BccEras StandardCrypto))))
-> Either Text LedgerStateEvents
forall a b. (a -> b) -> a -> b
$ Except
  (HardForkLedgerError (BccEras StandardCrypto))
  (LedgerResult
     (LedgerState (HardForkBlock (BccEras StandardCrypto)))
     (LedgerState (HardForkBlock (BccEras StandardCrypto))))
-> Either
     (HardForkLedgerError (BccEras StandardCrypto))
     (LedgerResult
        (LedgerState (HardForkBlock (BccEras StandardCrypto)))
        (LedgerState (HardForkBlock (BccEras StandardCrypto))))
forall e a. Except e a -> Either e a
runExcept
  (Except
   (HardForkLedgerError (BccEras StandardCrypto))
   (LedgerResult
      (LedgerState (HardForkBlock (BccEras StandardCrypto)))
      (LedgerState (HardForkBlock (BccEras StandardCrypto))))
 -> Either
      (HardForkLedgerError (BccEras StandardCrypto))
      (LedgerResult
         (LedgerState (HardForkBlock (BccEras StandardCrypto)))
         (LedgerState (HardForkBlock (BccEras StandardCrypto)))))
-> Except
     (HardForkLedgerError (BccEras StandardCrypto))
     (LedgerResult
        (LedgerState (HardForkBlock (BccEras StandardCrypto)))
        (LedgerState (HardForkBlock (BccEras StandardCrypto))))
-> Either
     (HardForkLedgerError (BccEras StandardCrypto))
     (LedgerResult
        (LedgerState (HardForkBlock (BccEras StandardCrypto)))
        (LedgerState (HardForkBlock (BccEras StandardCrypto))))
forall a b. (a -> b) -> a -> b
$ LedgerConfig (HardForkBlock (BccEras StandardCrypto))
-> HardForkBlock (BccEras StandardCrypto)
-> LedgerState (HardForkBlock (BccEras StandardCrypto))
-> Except
     (LedgerErr (LedgerState (HardForkBlock (BccEras StandardCrypto))))
     (LedgerResult
        (LedgerState (HardForkBlock (BccEras StandardCrypto)))
        (LedgerState (HardForkBlock (BccEras StandardCrypto))))
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) (LedgerResult l l)
Ledger.tickThenApplyLedgerResult LedgerConfig (HardForkBlock (BccEras StandardCrypto))
HardForkLedgerConfig (BccEras StandardCrypto)
cfg HardForkBlock (BccEras StandardCrypto)
block LedgerState (HardForkBlock (BccEras 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 :: Shardagnostic.Network.Block.ChainHash (Consensus.BccBlock era) -> ByteString
unChainHash :: ChainHash (BccBlock era) -> ByteString
unChainHash ChainHash (BccBlock era)
ch =
  case ChainHash (BccBlock era)
ch of
    ChainHash (BccBlock era)
Shardagnostic.Network.Block.GenesisHash -> ByteString
"genesis"
    Shardagnostic.Network.Block.BlockHash HeaderHash (BccBlock era)
bh -> ShortByteString -> ByteString
BSS.fromShort (OneEraHash
  '[ColeBlock, SophieBlock (SophieEra era),
    SophieBlock (EvieEra era), SophieBlock (JenEra era),
    SophieBlock (AurumEra era)]
-> ShortByteString
forall k (xs :: [k]). OneEraHash xs -> ShortByteString
HFC.getOneEraHash HeaderHash (BccBlock era)
OneEraHash
  '[ColeBlock, SophieBlock (SophieEra era),
    SophieBlock (EvieEra era), SophieBlock (JenEra era),
    SophieBlock (AurumEra era)]
bh)