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

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

    -- * Traversing the block chain
  , foldBlocks

   -- * 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           Cardano.Api.Block
import           Cardano.Api.Eras
import           Cardano.Api.IPC (ConsensusModeParams (CardanoModeParams), EpochSlots (..),
                   LocalChainSyncClient (LocalChainSyncClientPipelined),
                   LocalNodeClientProtocols (..), LocalNodeClientProtocolsInMode,
                   LocalNodeConnectInfo (..), connectToLocalNode)
import           Cardano.Api.Modes (CardanoMode)
import           Cardano.Api.NetworkId (NetworkId (..), NetworkMagic (NetworkMagic))
import qualified Cardano.Chain.Genesis
import qualified Cardano.Chain.Update
import           Cardano.Crypto (ProtocolMagicId (unProtocolMagicId), RequiresNetworkMagic (..))
import qualified Cardano.Crypto.Hash.Blake2b
import qualified Cardano.Crypto.Hash.Class
import qualified Cardano.Crypto.Hashing
import qualified Cardano.Crypto.ProtocolMagic
import           Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..))
import qualified Cardano.Ledger.BaseTypes as Shelley.Spec
import qualified Cardano.Ledger.Credential as Shelley.Spec
import qualified Cardano.Ledger.Keys as Shelley.Spec
import           Cardano.Slotting.Slot (WithOrigin (At, Origin))
import qualified Cardano.Slotting.Slot as Slot
import           Network.TypedProtocol.Pipelined (Nat (..))
import qualified Ouroboros.Consensus.Block.Abstract as Consensus
import qualified Ouroboros.Consensus.Byron.Ledger.Block as Byron
import qualified Ouroboros.Consensus.Cardano as Consensus
import qualified Ouroboros.Consensus.Cardano.Block as Consensus
import qualified Ouroboros.Consensus.Cardano.CanHardFork as Consensus
import qualified Ouroboros.Consensus.Cardano.Node as Consensus
import qualified Ouroboros.Consensus.Config as Consensus
import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus
import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as HFC
import qualified Ouroboros.Consensus.HardFork.Combinator.Basics as HFC
import qualified Ouroboros.Consensus.Ledger.Abstract as Ledger
import qualified Ouroboros.Consensus.Ledger.Extended as Ledger
import qualified Ouroboros.Consensus.Mempool.TxLimits as TxLimits
import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus
import qualified Ouroboros.Consensus.Shelley.Eras as Shelley
import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Shelley
import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Shelley
import qualified Ouroboros.Consensus.Shelley.Protocol as Shelley
import qualified Ouroboros.Network.Block
import           Ouroboros.Network.Protocol.ChainSync.ClientPipelined
                   (ChainSyncClientPipelined (ChainSyncClientPipelined),
                   ClientPipelinedStIdle (CollectResponse, SendMsgDone, SendMsgRequestNextPipelined),
                   ClientStNext (..))
import           Ouroboros.Network.Protocol.ChainSync.PipelineDecision
import qualified Shelley.Spec.Ledger.Genesis as Shelley.Spec
import qualified Shelley.Spec.Ledger.PParams as Shelley.Spec

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 cardano-node config file (e.g. <path to cardano-node project>/configuration/cardano/mainnet-config.json)
  ->  ExceptT InitialLedgerStateError IO (Env, LedgerState)
  -- ^ The environment and initial ledger state
initialLedgerState :: 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
readCardanoGenesisConfig NodeConfig
config)
  Env
env <- (GenesisConfigError -> InitialLedgerStateError)
-> ExceptT GenesisConfigError IO Env
-> ExceptT InitialLedgerStateError IO Env
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT GenesisConfigError -> InitialLedgerStateError
ILSELedgerConsensusConfig (Either GenesisConfigError Env -> ExceptT GenesisConfigError IO Env
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (GenesisConfig -> Either GenesisConfigError Env
genesisConfigToEnv GenesisConfig
genesisConfig))
  let ledgerState :: LedgerState
ledgerState = GenesisConfig -> LedgerState
initLedgerStateVar GenesisConfig
genesisConfig
  (Env, LedgerState)
-> ExceptT InitialLedgerStateError IO (Env, LedgerState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env
env, LedgerState
ledgerState)

-- | Apply a single block to the current ledger state.
applyBlock
  :: Env
  -- ^ The environment returned by @initialLedgerState@
  -> LedgerState
  -- ^ The current ledger state
  -> Bool
  -- ^ True to perform validation. If True, `tickThenApply` will be used instead
  -- of `tickThenReapply`.
  -> Block era
  -- ^ Some block to apply
  -> Either Text LedgerState
  -- ^ The new ledger state (or an error).
applyBlock :: Env -> LedgerState -> Bool -> Block era -> Either Text LedgerState
applyBlock Env
env LedgerState
oldState Bool
enableValidation Block era
block
  = Env
-> LedgerState
-> Bool
-> HardForkBlock (CardanoEras StandardCrypto)
-> Either Text LedgerState
applyBlock' Env
env LedgerState
oldState Bool
enableValidation (HardForkBlock (CardanoEras StandardCrypto)
 -> Either Text LedgerState)
-> HardForkBlock (CardanoEras StandardCrypto)
-> Either Text LedgerState
forall a b. (a -> b) -> a -> b
$ case Block era
block of
      ByronBlock ByronBlock
byronBlock -> ByronBlock -> HardForkBlock (CardanoEras StandardCrypto)
forall c. ByronBlock -> CardanoBlock c
Consensus.BlockByron ByronBlock
byronBlock
      ShelleyBlock ShelleyBasedEra era
blockEra ShelleyBlock (ShelleyLedgerEra era)
shelleyBlock -> case ShelleyBasedEra era
blockEra of
        ShelleyBasedEra era
ShelleyBasedEraShelley -> ShelleyBlock (ShelleyEra StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
forall c. ShelleyBlock (ShelleyEra c) -> CardanoBlock c
Consensus.BlockShelley ShelleyBlock (ShelleyEra StandardCrypto)
ShelleyBlock (ShelleyLedgerEra era)
shelleyBlock
        ShelleyBasedEra era
ShelleyBasedEraAllegra -> ShelleyBlock (AllegraEra StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
forall c. ShelleyBlock (AllegraEra c) -> CardanoBlock c
Consensus.BlockAllegra ShelleyBlock (AllegraEra StandardCrypto)
ShelleyBlock (ShelleyLedgerEra era)
shelleyBlock
        ShelleyBasedEra era
ShelleyBasedEraMary    -> ShelleyBlock (MaryEra StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
forall c. ShelleyBlock (MaryEra c) -> CardanoBlock c
Consensus.BlockMary ShelleyBlock (MaryEra StandardCrypto)
ShelleyBlock (ShelleyLedgerEra era)
shelleyBlock
        ShelleyBasedEra era
ShelleyBasedEraAlonzo  -> ShelleyBlock (AlonzoEra StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
forall c. ShelleyBlock (AlonzoEra c) -> CardanoBlock c
Consensus.BlockAlonzo ShelleyBlock (AlonzoEra StandardCrypto)
ShelleyBlock (ShelleyLedgerEra era)
shelleyBlock

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

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

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

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

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

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 cardano-node config file (e.g. <path to cardano-node project>/configuration/cardano/mainnet-config.json)
  -> FilePath
  -- ^ Path to local cardano-node socket. This is the path specified by the @--socket-path@ command line option when running the node.
  -> Bool
  -- ^ True to enable validation. Under the hood this will use @applyBlock@
  -- instead of @reapplyBlock@ from the @ApplyBlock@ type class.
  -> a
  -- ^ The initial accumulator state.
  -> (Env -> LedgerState -> BlockInMode CardanoMode -> a -> IO a)
  -- ^ Accumulator function Takes:
  --  * Environment (this is a constant over the whole fold)
  --  * The current Ledger state (with the current block applied)
  --  * The current Block
  --  * The previous state
  --
  -- And this should return the new state.
  --
  -- 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
-> FilePath
-> Bool
-> a
-> (Env -> LedgerState -> BlockInMode CardanoMode -> a -> IO a)
-> ExceptT FoldBlocksError IO a
foldBlocks FilePath
nodeConfigFilePath FilePath
socketPath Bool
enableValidation a
state0 Env -> LedgerState -> BlockInMode CardanoMode -> a -> IO a
accumulate = do
  -- NOTE this was originally implemented with a non-pipelined client then
  -- changed to a pipelined client for a modest speedup:
  --  * Non-pipelined: 1h  0m  19s
  --  * Pipelined:        46m  23s

  (Env
env, LedgerState
ledgerState) <- (InitialLedgerStateError -> FoldBlocksError)
-> ExceptT InitialLedgerStateError IO (Env, LedgerState)
-> ExceptT FoldBlocksError IO (Env, LedgerState)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT InitialLedgerStateError -> FoldBlocksError
FoldBlocksInitialLedgerStateError
                            (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
  -- cardano-ledger-specs repo.
  let byronConfig :: Config
byronConfig
        = (\(Consensus.WrapPartialLedgerConfig (Consensus.ByronPartialLedgerConfig bc _) :* NP WrapPartialLedgerConfig xs
_) -> LedgerConfig ByronBlock
Config
bc)
        (NP WrapPartialLedgerConfig (CardanoEras StandardCrypto) -> Config)
-> (HardForkLedgerConfig (CardanoEras StandardCrypto)
    -> NP WrapPartialLedgerConfig (CardanoEras StandardCrypto))
-> HardForkLedgerConfig (CardanoEras StandardCrypto)
-> Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerEraLedgerConfig (CardanoEras StandardCrypto)
-> NP WrapPartialLedgerConfig (CardanoEras StandardCrypto)
forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
HFC.getPerEraLedgerConfig
        (PerEraLedgerConfig (CardanoEras StandardCrypto)
 -> NP WrapPartialLedgerConfig (CardanoEras StandardCrypto))
-> (HardForkLedgerConfig (CardanoEras StandardCrypto)
    -> PerEraLedgerConfig (CardanoEras StandardCrypto))
-> HardForkLedgerConfig (CardanoEras StandardCrypto)
-> NP WrapPartialLedgerConfig (CardanoEras StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkLedgerConfig (CardanoEras StandardCrypto)
-> PerEraLedgerConfig (CardanoEras StandardCrypto)
forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
HFC.hardForkLedgerConfigPerEra
        (HardForkLedgerConfig (CardanoEras StandardCrypto) -> Config)
-> HardForkLedgerConfig (CardanoEras StandardCrypto) -> Config
forall a b. (a -> b) -> a -> b
$ Env -> HardForkLedgerConfig (CardanoEras StandardCrypto)
envLedgerConfig Env
env

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

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

  -- Connect to the node.
  let connectInfo :: LocalNodeConnectInfo CardanoMode
      connectInfo :: LocalNodeConnectInfo CardanoMode
connectInfo =
          LocalNodeConnectInfo :: forall mode.
ConsensusModeParams mode
-> NetworkId -> FilePath -> LocalNodeConnectInfo mode
LocalNodeConnectInfo {
            localConsensusModeParams :: ConsensusModeParams CardanoMode
localConsensusModeParams = EpochSlots -> ConsensusModeParams CardanoMode
CardanoModeParams (Word64 -> EpochSlots
EpochSlots Word64
21600),
            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 CardanoMode
-> LocalNodeClientProtocolsInMode CardanoMode -> IO ()
forall mode.
LocalNodeConnectInfo mode
-> LocalNodeClientProtocolsInMode mode -> IO ()
connectToLocalNode
    LocalNodeConnectInfo CardanoMode
connectInfo
    (IORef a
-> IORef (Maybe Text)
-> Env
-> LedgerState
-> LocalNodeClientProtocolsInMode CardanoMode
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 CardanoMode
    protocols :: IORef a
-> IORef (Maybe Text)
-> Env
-> LedgerState
-> LocalNodeClientProtocolsInMode CardanoMode
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 CardanoMode) ChainPoint ChainTip IO
localChainSyncClient    = ChainSyncClientPipelined
  (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> LocalChainSyncClient
     (BlockInMode CardanoMode) ChainPoint ChainTip IO
forall block point tip (m :: * -> *).
ChainSyncClientPipelined block point tip m ()
-> LocalChainSyncClient block point tip m
LocalChainSyncClientPipelined (Word32
-> IORef a
-> IORef (Maybe Text)
-> Env
-> LedgerState
-> ChainSyncClientPipelined
     (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
chainSyncClient Word32
50 IORef a
stateIORef IORef (Maybe Text)
errorIORef Env
env LedgerState
ledgerState),
          localTxSubmissionClient :: Maybe
  (LocalTxSubmissionClient
     (TxInMode CardanoMode) (TxValidationErrorInMode CardanoMode) IO ())
localTxSubmissionClient = Maybe
  (LocalTxSubmissionClient
     (TxInMode CardanoMode) (TxValidationErrorInMode CardanoMode) IO ())
forall a. Maybe a
Nothing,
          localStateQueryClient :: Maybe
  (LocalStateQueryClient
     (BlockInMode CardanoMode)
     ChainPoint
     (QueryInMode CardanoMode)
     IO
     ())
localStateQueryClient   = Maybe
  (LocalStateQueryClient
     (BlockInMode CardanoMode)
     ChainPoint
     (QueryInMode CardanoMode)
     IO
     ())
forall a. Maybe a
Nothing
        }

    -- | Add a new ledger state to the history
    pushLedgerState
      :: Env                -- ^ Environement used to get the security param, k.
      -> LedgerStateHistory -- ^ History of k ledger states.
      -> SlotNo             -- ^ Slot number of the new ledger state.
      -> LedgerState        -- ^ New ledger state to add to the history
      -> BlockInMode CardanoMode
                            -- ^ The block that (when applied to the previous
                            -- ledger state) resulted in the new ledger state.
      -> (LedgerStateHistory, LedgerStateHistory)
      -- ^ ( The new history with the new state appended
      --   , Any exisiting ledger states that are now past the security parameter
      --      and hence can no longer be rolled back.
      --   )
    pushLedgerState :: Env
-> LedgerStateHistory
-> SlotNo
-> LedgerState
-> BlockInMode CardanoMode
-> (LedgerStateHistory, LedgerStateHistory)
pushLedgerState Env
env LedgerStateHistory
hist SlotNo
ix LedgerState
st BlockInMode CardanoMode
block
      = Int
-> LedgerStateHistory -> (LedgerStateHistory, LedgerStateHistory)
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, LedgerState
st, BlockInMode CardanoMode -> WithOrigin (BlockInMode CardanoMode)
forall t. t -> WithOrigin t
At BlockInMode CardanoMode
block) (SlotNo, LedgerState, WithOrigin (BlockInMode CardanoMode))
-> LedgerStateHistory -> LedgerStateHistory
forall a. a -> Seq a -> Seq a
Seq.:<| LedgerStateHistory
hist)

    rollBackLedgerStateHist :: LedgerStateHistory -> SlotNo -> LedgerStateHistory
    rollBackLedgerStateHist :: LedgerStateHistory -> SlotNo -> LedgerStateHistory
rollBackLedgerStateHist LedgerStateHistory
hist SlotNo
maxInc = ((SlotNo, LedgerState, WithOrigin (BlockInMode CardanoMode))
 -> Bool)
-> LedgerStateHistory -> LedgerStateHistory
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, LedgerState, WithOrigin (BlockInMode CardanoMode))
    -> SlotNo)
-> (SlotNo, LedgerState, WithOrigin (BlockInMode CardanoMode))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(SlotNo
x,LedgerState
_,WithOrigin (BlockInMode CardanoMode)
_) -> SlotNo
x)) LedgerStateHistory
hist

    -- | 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
                    -> ChainSyncClientPipelined
                        (BlockInMode CardanoMode)
                        ChainPoint
                        ChainTip
                        IO ()
                    -- ^ Client returns maybe an error.
    chainSyncClient :: Word32
-> IORef a
-> IORef (Maybe Text)
-> Env
-> LedgerState
-> ChainSyncClientPipelined
     (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
chainSyncClient Word32
pipelineSize IORef a
stateIORef IORef (Maybe Text)
errorIORef Env
env LedgerState
ledgerState0
      = IO
  (ClientPipelinedStIdle
     'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
-> ChainSyncClientPipelined
     (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
forall header point tip (m :: * -> *) a.
m (ClientPipelinedStIdle 'Z header point tip m a)
-> ChainSyncClientPipelined header point tip m a
ChainSyncClientPipelined (IO
   (ClientPipelinedStIdle
      'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
 -> ChainSyncClientPipelined
      (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
-> IO
     (ClientPipelinedStIdle
        'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
-> ChainSyncClientPipelined
     (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
forall a b. (a -> b) -> a -> b
$ ClientPipelinedStIdle
  'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle
        'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientPipelinedStIdle
   'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
 -> IO
      (ClientPipelinedStIdle
         'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ()))
-> ClientPipelinedStIdle
     'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
-> IO
     (ClientPipelinedStIdle
        'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
forall a b. (a -> b) -> a -> b
$ WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat 'Z
-> LedgerStateHistory
-> ClientPipelinedStIdle
     'Z (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
forall (n :: N).
WithOrigin BlockNo
-> WithOrigin BlockNo
-> Nat n
-> LedgerStateHistory
-> ClientPipelinedStIdle
     n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
clientIdle_RequestMoreN WithOrigin BlockNo
forall t. WithOrigin t
Origin WithOrigin BlockNo
forall t. WithOrigin t
Origin Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero LedgerStateHistory
initialLedgerStateHistory
      where
          initialLedgerStateHistory :: LedgerStateHistory
initialLedgerStateHistory = (SlotNo, LedgerState, WithOrigin (BlockInMode CardanoMode))
-> LedgerStateHistory
forall a. a -> Seq a
Seq.singleton (SlotNo
0, LedgerState
ledgerState0, WithOrigin (BlockInMode CardanoMode)
forall t. WithOrigin t
Origin)

          pushLedgerState' :: LedgerStateHistory
-> SlotNo
-> LedgerState
-> BlockInMode CardanoMode
-> (LedgerStateHistory, LedgerStateHistory)
pushLedgerState' = Env
-> LedgerStateHistory
-> SlotNo
-> LedgerState
-> BlockInMode CardanoMode
-> (LedgerStateHistory, LedgerStateHistory)
pushLedgerState Env
env

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

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

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

          clientNext_DoneN
            :: Nat n -- Number of requests inflight.
            -> Maybe Text -- Return value (maybe an error)
            -> ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
          clientNext_DoneN :: Nat n
-> Maybe Text
-> ClientStNext
     n (BlockInMode CardanoMode) 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
ClientStNext {
                recvMsgRollForward :: BlockInMode CardanoMode
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
recvMsgRollForward = \BlockInMode CardanoMode
_ ChainTip
_ -> Nat n
-> Maybe Text
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe Text
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
clientIdle_DoneN Nat n
n Maybe Text
errorMay
              , recvMsgRollBackward :: ChainPoint
-> ChainTip
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
recvMsgRollBackward = \ChainPoint
_ ChainTip
_ -> Nat n
-> Maybe Text
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
forall (n :: N).
Nat n
-> Maybe Text
-> IO
     (ClientPipelinedStIdle
        n (BlockInMode CardanoMode) 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

-- | 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 = Seq (SlotNo, LedgerState, WithOrigin (BlockInMode CardanoMode))

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

genesisConfigToEnv
  :: GenesisConfig
  -> Either GenesisConfigError Env
genesisConfigToEnv :: GenesisConfig -> Either GenesisConfigError Env
genesisConfigToEnv
  -- enp
  GenesisConfig
genCfg =
    case GenesisConfig
genCfg of
      GenesisCardano NodeConfig
_ Config
bCfg ShelleyConfig
sCfg AlonzoGenesis
_
        | ProtocolMagicId -> Word32
Cardano.Crypto.ProtocolMagic.unProtocolMagicId (Config -> ProtocolMagicId
Cardano.Chain.Genesis.configProtocolMagicId Config
bCfg) Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= ShelleyGenesis (ShelleyEra StandardCrypto) -> Word32
forall era. ShelleyGenesis era -> Word32
Shelley.Spec.sgNetworkMagic (ShelleyConfig -> ShelleyGenesis (ShelleyEra StandardCrypto)
scConfig ShelleyConfig
sCfg) ->
            GenesisConfigError -> Either GenesisConfigError Env
forall a b. a -> Either a b
Left (GenesisConfigError -> Either GenesisConfigError Env)
-> (Text -> GenesisConfigError)
-> Text
-> Either GenesisConfigError Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> GenesisConfigError
NECardanoConfig (Text -> Either GenesisConfigError Env)
-> Text -> Either GenesisConfigError Env
forall a b. (a -> b) -> a -> b
$
              [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
"ProtocolMagicId ", Word32 -> Text
forall a. Show a => a -> Text
textShow (ProtocolMagicId -> Word32
Cardano.Crypto.ProtocolMagic.unProtocolMagicId (ProtocolMagicId -> Word32) -> ProtocolMagicId -> Word32
forall a b. (a -> b) -> a -> b
$ Config -> ProtocolMagicId
Cardano.Chain.Genesis.configProtocolMagicId Config
bCfg)
                , Text
" /= ", Word32 -> Text
forall a. Show a => a -> Text
textShow (ShelleyGenesis (ShelleyEra StandardCrypto) -> Word32
forall era. ShelleyGenesis era -> Word32
Shelley.Spec.sgNetworkMagic (ShelleyGenesis (ShelleyEra StandardCrypto) -> Word32)
-> ShelleyGenesis (ShelleyEra StandardCrypto) -> Word32
forall a b. (a -> b) -> a -> b
$ ShelleyConfig -> ShelleyGenesis (ShelleyEra StandardCrypto)
scConfig ShelleyConfig
sCfg)
                ]
        | GenesisData -> UTCTime
Cardano.Chain.Genesis.gdStartTime (Config -> GenesisData
Cardano.Chain.Genesis.configGenesisData Config
bCfg) UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
/= ShelleyGenesis (ShelleyEra StandardCrypto) -> UTCTime
forall era. ShelleyGenesis era -> UTCTime
Shelley.Spec.sgSystemStart (ShelleyConfig -> ShelleyGenesis (ShelleyEra StandardCrypto)
scConfig ShelleyConfig
sCfg) ->
            GenesisConfigError -> Either GenesisConfigError Env
forall a b. a -> Either a b
Left (GenesisConfigError -> Either GenesisConfigError Env)
-> (Text -> GenesisConfigError)
-> Text
-> Either GenesisConfigError Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> GenesisConfigError
NECardanoConfig (Text -> Either GenesisConfigError Env)
-> Text -> Either GenesisConfigError Env
forall a b. (a -> b) -> a -> b
$
              [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
"SystemStart ", UTCTime -> Text
forall a. Show a => a -> Text
textShow (GenesisData -> UTCTime
Cardano.Chain.Genesis.gdStartTime (GenesisData -> UTCTime) -> GenesisData -> UTCTime
forall a b. (a -> b) -> a -> b
$ Config -> GenesisData
Cardano.Chain.Genesis.configGenesisData Config
bCfg)
                , Text
" /= ", UTCTime -> Text
forall a. Show a => a -> Text
textShow (ShelleyGenesis (ShelleyEra StandardCrypto) -> UTCTime
forall era. ShelleyGenesis era -> UTCTime
Shelley.Spec.sgSystemStart (ShelleyGenesis (ShelleyEra StandardCrypto) -> UTCTime)
-> ShelleyGenesis (ShelleyEra StandardCrypto) -> UTCTime
forall a b. (a -> b) -> a -> b
$ ShelleyConfig -> ShelleyGenesis (ShelleyEra StandardCrypto)
scConfig ShelleyConfig
sCfg)
                ]
        | Bool
otherwise ->
            let
              topLevelConfig :: TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
topLevelConfig = ProtocolInfo IO (HardForkBlock (CardanoEras StandardCrypto))
-> TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
forall (m :: * -> *) b. ProtocolInfo m b -> TopLevelConfig b
Consensus.pInfoConfig (GenesisConfig
-> ProtocolInfo IO (HardForkBlock (CardanoEras StandardCrypto))
mkProtocolInfoCardano GenesisConfig
genCfg)
            in
            Env -> Either GenesisConfigError Env
forall a b. b -> Either a b
Right (Env -> Either GenesisConfigError Env)
-> Env -> Either GenesisConfigError Env
forall a b. (a -> b) -> a -> b
$ Env :: HardForkLedgerConfig (CardanoEras StandardCrypto)
-> ConsensusConfig (HardForkProtocol (CardanoEras StandardCrypto))
-> Env
Env
                  { envLedgerConfig :: HardForkLedgerConfig (CardanoEras StandardCrypto)
envLedgerConfig = TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
-> LedgerConfig (HardForkBlock (CardanoEras StandardCrypto))
forall blk. TopLevelConfig blk -> LedgerConfig blk
Consensus.topLevelConfigLedger TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
topLevelConfig
                  , envProtocolConfig :: ConsensusConfig (HardForkProtocol (CardanoEras StandardCrypto))
envProtocolConfig = TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
-> ConsensusConfig
     (BlockProtocol (HardForkBlock (CardanoEras StandardCrypto)))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
Consensus.topLevelConfigProtocol TopLevelConfig (HardForkBlock (CardanoEras StandardCrypto))
topLevelConfig
                  }

readNetworkConfig :: NetworkConfigFile -> ExceptT Text IO NodeConfig
readNetworkConfig :: NetworkConfigFile -> ExceptT Text IO NodeConfig
readNetworkConfig (NetworkConfigFile 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
      { ncByronGenesisFile :: GenesisFile
ncByronGenesisFile = (FilePath -> FilePath) -> GenesisFile -> GenesisFile
adjustGenesisFilePath (FilePath -> FilePath -> FilePath
mkAdjustPath FilePath
ncf) (NodeConfig -> GenesisFile
ncByronGenesisFile NodeConfig
ncfg)
      , ncShelleyGenesisFile :: GenesisFile
ncShelleyGenesisFile = (FilePath -> FilePath) -> GenesisFile -> GenesisFile
adjustGenesisFilePath (FilePath -> FilePath -> FilePath
mkAdjustPath FilePath
ncf) (NodeConfig -> GenesisFile
ncShelleyGenesisFile NodeConfig
ncfg)
      , ncAlonzoGenesisFile :: GenesisFile
ncAlonzoGenesisFile = (FilePath -> FilePath) -> GenesisFile -> GenesisFile
adjustGenesisFilePath (FilePath -> FilePath -> FilePath
mkAdjustPath FilePath
ncf) (NodeConfig -> GenesisFile
ncAlonzoGenesisFile NodeConfig
ncfg)
      }

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

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

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
-> GenesisHashByron
-> GenesisFile
-> GenesisHashShelley
-> GenesisFile
-> GenesisHashAlonzo
-> RequiresNetworkMagic
-> SoftwareVersion
-> ProtocolVersion
-> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
-> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
-> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
-> TriggerHardFork
-> NodeConfig
NodeConfig
          (Maybe Double
 -> GenesisFile
 -> GenesisHashByron
 -> GenesisFile
 -> GenesisHashShelley
 -> GenesisFile
 -> GenesisHashAlonzo
 -> RequiresNetworkMagic
 -> SoftwareVersion
 -> ProtocolVersion
 -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
 -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
 -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
 -> TriggerHardFork
 -> NodeConfig)
-> Parser (Maybe Double)
-> Parser
     (GenesisFile
      -> GenesisHashByron
      -> GenesisFile
      -> GenesisHashShelley
      -> GenesisFile
      -> GenesisHashAlonzo
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> 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
   -> GenesisHashByron
   -> GenesisFile
   -> GenesisHashShelley
   -> GenesisFile
   -> GenesisHashAlonzo
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisFile
-> Parser
     (GenesisHashByron
      -> GenesisFile
      -> GenesisHashShelley
      -> GenesisFile
      -> GenesisHashAlonzo
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra 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
"ByronGenesisFile")
          Parser
  (GenesisHashByron
   -> GenesisFile
   -> GenesisHashShelley
   -> GenesisFile
   -> GenesisHashAlonzo
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisHashByron
-> Parser
     (GenesisFile
      -> GenesisHashShelley
      -> GenesisFile
      -> GenesisHashAlonzo
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> GenesisHashByron)
-> Parser Text -> Parser GenesisHashByron
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> GenesisHashByron
GenesisHashByron (Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"ByronGenesisHash")
          Parser
  (GenesisFile
   -> GenesisHashShelley
   -> GenesisFile
   -> GenesisHashAlonzo
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisFile
-> Parser
     (GenesisHashShelley
      -> GenesisFile
      -> GenesisHashAlonzo
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra 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
"ShelleyGenesisFile")
          Parser
  (GenesisHashShelley
   -> GenesisFile
   -> GenesisHashAlonzo
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisHashShelley
-> Parser
     (GenesisFile
      -> GenesisHashAlonzo
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Hash Blake2b_256 ByteString -> GenesisHashShelley)
-> Parser (Hash Blake2b_256 ByteString)
-> Parser GenesisHashShelley
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Hash Blake2b_256 ByteString -> GenesisHashShelley
GenesisHashShelley (Object
o Object -> Text -> Parser (Hash Blake2b_256 ByteString)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"ShelleyGenesisHash")
          Parser
  (GenesisFile
   -> GenesisHashAlonzo
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisFile
-> Parser
     (GenesisHashAlonzo
      -> RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra 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
"AlonzoGenesisFile")
          Parser
  (GenesisHashAlonzo
   -> RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser GenesisHashAlonzo
-> Parser
     (RequiresNetworkMagic
      -> SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Hash Blake2b_256 ByteString -> GenesisHashAlonzo)
-> Parser (Hash Blake2b_256 ByteString) -> Parser GenesisHashAlonzo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Hash Blake2b_256 ByteString -> GenesisHashAlonzo
GenesisHashAlonzo (Object
o Object -> Text -> Parser (Hash Blake2b_256 ByteString)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"AlonzoGenesisHash")
          Parser
  (RequiresNetworkMagic
   -> SoftwareVersion
   -> ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser RequiresNetworkMagic
-> Parser
     (SoftwareVersion
      -> ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra 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
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser SoftwareVersion
-> Parser
     (ProtocolVersion
      -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser SoftwareVersion
parseByronSoftwareVersion Object
o
          Parser
  (ProtocolVersion
   -> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser ProtocolVersion
-> Parser
     (ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser ProtocolVersion
parseByronProtocolVersion Object
o
          Parser
  (ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser
     (ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto))
-> Parser
     (ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
      -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork
      -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TranslationContext (ShelleyEra StandardCrypto)
-> TriggerHardFork
-> ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto)
forall era.
TranslationContext era
-> TriggerHardFork -> ProtocolTransitionParamsShelleyBased era
Consensus.ProtocolTransitionParamsShelleyBased ()
                 (TriggerHardFork
 -> ProtocolTransitionParamsShelleyBased
      (ShelleyEra StandardCrypto))
-> Parser TriggerHardFork
-> Parser
     (ProtocolTransitionParamsShelleyBased (ShelleyEra StandardCrypto))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser TriggerHardFork
parseShelleyHardForkEpoch Object
o)
          Parser
  (ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
   -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork
   -> NodeConfig)
-> Parser
     (ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto))
-> Parser
     (ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
      -> TriggerHardFork -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TranslationContext (AllegraEra StandardCrypto)
-> TriggerHardFork
-> ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto)
forall era.
TranslationContext era
-> TriggerHardFork -> ProtocolTransitionParamsShelleyBased era
Consensus.ProtocolTransitionParamsShelleyBased ()
                 (TriggerHardFork
 -> ProtocolTransitionParamsShelleyBased
      (AllegraEra StandardCrypto))
-> Parser TriggerHardFork
-> Parser
     (ProtocolTransitionParamsShelleyBased (AllegraEra StandardCrypto))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser TriggerHardFork
parseAllegraHardForkEpoch Object
o)
          Parser
  (ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
   -> TriggerHardFork -> NodeConfig)
-> Parser
     (ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto))
-> Parser (TriggerHardFork -> NodeConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TranslationContext (MaryEra StandardCrypto)
-> TriggerHardFork
-> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto)
forall era.
TranslationContext era
-> TriggerHardFork -> ProtocolTransitionParamsShelleyBased era
Consensus.ProtocolTransitionParamsShelleyBased ()
                 (TriggerHardFork
 -> ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto))
-> Parser TriggerHardFork
-> Parser
     (ProtocolTransitionParamsShelleyBased (MaryEra StandardCrypto))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser TriggerHardFork
parseMaryHardForkEpoch Object
o)
          Parser (TriggerHardFork -> NodeConfig)
-> Parser TriggerHardFork -> Parser NodeConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser TriggerHardFork
parseAlonzoHardForkEpoch Object
o

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

      parseByronSoftwareVersion :: Object -> Data.Aeson.Types.Internal.Parser Cardano.Chain.Update.SoftwareVersion
      parseByronSoftwareVersion :: Object -> Parser SoftwareVersion
parseByronSoftwareVersion Object
o =
        ApplicationName -> Word32 -> SoftwareVersion
Cardano.Chain.Update.SoftwareVersion
          (ApplicationName -> Word32 -> SoftwareVersion)
-> Parser ApplicationName -> Parser (Word32 -> SoftwareVersion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> ApplicationName) -> Parser Text -> Parser ApplicationName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ApplicationName
Cardano.Chain.Update.ApplicationName (Object
o Object -> 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"

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

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

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

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

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 (CardanoEras StandardCrypto))
-> LedgerState
LedgerState
  { clsState :: LedgerState (HardForkBlock (CardanoEras StandardCrypto))
clsState = ExtLedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
forall blk. ExtLedgerState blk -> LedgerState blk
Ledger.ledgerState (ExtLedgerState (HardForkBlock (CardanoEras StandardCrypto))
 -> LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> ExtLedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
forall a b. (a -> b) -> a -> b
$ ProtocolInfo IO (HardForkBlock (CardanoEras StandardCrypto))
-> ExtLedgerState (HardForkBlock (CardanoEras StandardCrypto))
forall (m :: * -> *) b. ProtocolInfo m b -> ExtLedgerState b
Consensus.pInfoInitLedger ProtocolInfo IO (HardForkBlock (CardanoEras StandardCrypto))
protocolInfo
  }
  where
    protocolInfo :: ProtocolInfo IO (HardForkBlock (CardanoEras StandardCrypto))
protocolInfo = GenesisConfig
-> ProtocolInfo IO (HardForkBlock (CardanoEras StandardCrypto))
mkProtocolInfoCardano GenesisConfig
genesisConfig

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

-- Usually only one constructor, but may have two when we are preparing for a HFC event.
data GenesisConfig
  = GenesisCardano
      !NodeConfig
      !Cardano.Chain.Genesis.Config
      !ShelleyConfig
      !AlonzoGenesis

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

newtype GenesisFile = GenesisFile
  { GenesisFile -> 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 GenesisHashByron = GenesisHashByron
  { GenesisHashByron -> Text
unGenesisHashByron :: Text
  } deriving newtype (GenesisHashByron -> GenesisHashByron -> Bool
(GenesisHashByron -> GenesisHashByron -> Bool)
-> (GenesisHashByron -> GenesisHashByron -> Bool)
-> Eq GenesisHashByron
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenesisHashByron -> GenesisHashByron -> Bool
$c/= :: GenesisHashByron -> GenesisHashByron -> Bool
== :: GenesisHashByron -> GenesisHashByron -> Bool
$c== :: GenesisHashByron -> GenesisHashByron -> Bool
Eq, Int -> GenesisHashByron -> FilePath -> FilePath
[GenesisHashByron] -> FilePath -> FilePath
GenesisHashByron -> FilePath
(Int -> GenesisHashByron -> FilePath -> FilePath)
-> (GenesisHashByron -> FilePath)
-> ([GenesisHashByron] -> FilePath -> FilePath)
-> Show GenesisHashByron
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [GenesisHashByron] -> FilePath -> FilePath
$cshowList :: [GenesisHashByron] -> FilePath -> FilePath
show :: GenesisHashByron -> FilePath
$cshow :: GenesisHashByron -> FilePath
showsPrec :: Int -> GenesisHashByron -> FilePath -> FilePath
$cshowsPrec :: Int -> GenesisHashByron -> FilePath -> FilePath
Show)

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

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

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

shelleyPraosNonce :: ShelleyConfig -> Shelley.Spec.Nonce
shelleyPraosNonce :: ShelleyConfig -> Nonce
shelleyPraosNonce ShelleyConfig
sCfg = Hash Blake2b_256 Nonce -> Nonce
Shelley.Spec.Nonce (Hash Blake2b_256 ByteString -> Hash Blake2b_256 Nonce
forall h a b. Hash h a -> Hash h b
Cardano.Crypto.Hash.Class.castHash (Hash Blake2b_256 ByteString -> Hash Blake2b_256 Nonce)
-> (GenesisHashShelley -> Hash Blake2b_256 ByteString)
-> GenesisHashShelley
-> Hash Blake2b_256 Nonce
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenesisHashShelley -> Hash Blake2b_256 ByteString
unGenesisHashShelley (GenesisHashShelley -> Hash Blake2b_256 Nonce)
-> GenesisHashShelley -> Hash Blake2b_256 Nonce
forall a b. (a -> b) -> a -> b
$ ShelleyConfig -> GenesisHashShelley
scGenesisHash ShelleyConfig
sCfg)

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

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

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

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

data LookupFail
  = DbLookupBlockHash !ByteString
  | DbLookupBlockId !Word64
  | DbLookupMessage !Text
  | DbLookupTxHash !ByteString
  | DbLookupTxOutPair !ByteString !Word16
  | DbLookupEpochNo !Word64
  | DbLookupSlotNo !Word64
  | DbMetaEmpty
  | DbMetaMultipleRows
  deriving (LookupFail -> LookupFail -> Bool
(LookupFail -> LookupFail -> Bool)
-> (LookupFail -> LookupFail -> Bool) -> Eq LookupFail
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LookupFail -> LookupFail -> Bool
$c/= :: LookupFail -> LookupFail -> Bool
== :: LookupFail -> LookupFail -> Bool
$c== :: LookupFail -> LookupFail -> Bool
Eq, Int -> LookupFail -> 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)

readByronGenesisConfig
        :: NodeConfig
        -> ExceptT GenesisConfigError IO Cardano.Chain.Genesis.Config
readByronGenesisConfig :: NodeConfig -> ExceptT GenesisConfigError IO Config
readByronGenesisConfig NodeConfig
enc = do
  let file :: FilePath
file = GenesisFile -> FilePath
unGenesisFile (GenesisFile -> FilePath) -> GenesisFile -> FilePath
forall a b. (a -> b) -> a -> b
$ NodeConfig -> GenesisFile
ncByronGenesisFile NodeConfig
enc
  AbstractHash Blake2b_256 Raw
genHash <- (Text -> GenesisConfigError)
-> ExceptT Text IO (AbstractHash Blake2b_256 Raw)
-> ExceptT GenesisConfigError IO (AbstractHash Blake2b_256 Raw)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT Text -> GenesisConfigError
NEError
                (ExceptT Text IO (AbstractHash Blake2b_256 Raw)
 -> ExceptT GenesisConfigError IO (AbstractHash Blake2b_256 Raw))
-> (Either Text (AbstractHash Blake2b_256 Raw)
    -> ExceptT Text IO (AbstractHash Blake2b_256 Raw))
-> Either Text (AbstractHash Blake2b_256 Raw)
-> ExceptT GenesisConfigError IO (AbstractHash Blake2b_256 Raw)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text (AbstractHash Blake2b_256 Raw)
-> ExceptT Text IO (AbstractHash Blake2b_256 Raw)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither
                (Either Text (AbstractHash Blake2b_256 Raw)
 -> ExceptT GenesisConfigError IO (AbstractHash Blake2b_256 Raw))
-> Either Text (AbstractHash Blake2b_256 Raw)
-> ExceptT GenesisConfigError IO (AbstractHash Blake2b_256 Raw)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (AbstractHash Blake2b_256 Raw)
forall algo a.
HashAlgorithm algo =>
Text -> Either Text (AbstractHash algo a)
Cardano.Crypto.Hashing.decodeAbstractHash (GenesisHashByron -> Text
unGenesisHashByron (GenesisHashByron -> Text) -> GenesisHashByron -> Text
forall a b. (a -> b) -> a -> b
$ NodeConfig -> GenesisHashByron
ncByronGenesisHash NodeConfig
enc)
  (ConfigurationError -> GenesisConfigError)
-> ExceptT ConfigurationError IO Config
-> ExceptT GenesisConfigError IO Config
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT (FilePath -> ConfigurationError -> GenesisConfigError
NEByronConfig 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
Cardano.Chain.Genesis.mkConfigFromFile (NodeConfig -> RequiresNetworkMagic
ncRequiresNetworkMagic NodeConfig
enc) FilePath
file AbstractHash Blake2b_256 Raw
genHash

readShelleyGenesisConfig
    :: NodeConfig
    -> ExceptT GenesisConfigError IO ShelleyConfig
readShelleyGenesisConfig :: NodeConfig -> ExceptT GenesisConfigError IO ShelleyConfig
readShelleyGenesisConfig NodeConfig
enc = do
  let file :: FilePath
file = GenesisFile -> FilePath
unGenesisFile (GenesisFile -> FilePath) -> GenesisFile -> FilePath
forall a b. (a -> b) -> a -> b
$ NodeConfig -> GenesisFile
ncShelleyGenesisFile NodeConfig
enc
  (ShelleyGenesisError -> GenesisConfigError)
-> ExceptT ShelleyGenesisError IO ShelleyConfig
-> ExceptT GenesisConfigError IO ShelleyConfig
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT (FilePath -> Text -> GenesisConfigError
NEShelleyConfig FilePath
file (Text -> GenesisConfigError)
-> (ShelleyGenesisError -> Text)
-> ShelleyGenesisError
-> GenesisConfigError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesisError -> Text
renderShelleyGenesisError)
    (ExceptT ShelleyGenesisError IO ShelleyConfig
 -> ExceptT GenesisConfigError IO ShelleyConfig)
-> ExceptT ShelleyGenesisError IO ShelleyConfig
-> ExceptT GenesisConfigError IO ShelleyConfig
forall a b. (a -> b) -> a -> b
$ GenesisFile
-> GenesisHashShelley
-> ExceptT ShelleyGenesisError IO ShelleyConfig
readShelleyGenesis (FilePath -> GenesisFile
GenesisFile FilePath
file) (NodeConfig -> GenesisHashShelley
ncShelleyGenesisHash NodeConfig
enc)

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

readShelleyGenesis
    :: GenesisFile -> GenesisHashShelley
    -> ExceptT ShelleyGenesisError IO ShelleyConfig
readShelleyGenesis :: GenesisFile
-> GenesisHashShelley
-> ExceptT ShelleyGenesisError IO ShelleyConfig
readShelleyGenesis (GenesisFile FilePath
file) GenesisHashShelley
expectedGenesisHash = do
    ByteString
content <- (IOException -> ShelleyGenesisError)
-> IO ByteString -> ExceptT ShelleyGenesisError IO ByteString
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FilePath -> Text -> ShelleyGenesisError
ShelleyGenesisReadError FilePath
file (Text -> ShelleyGenesisError)
-> (IOException -> Text) -> IOException -> ShelleyGenesisError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> Text
forall a. Show a => a -> Text
textShow) (IO ByteString -> ExceptT ShelleyGenesisError IO ByteString)
-> IO ByteString -> ExceptT ShelleyGenesisError IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
BS.readFile FilePath
file
    let genesisHash :: GenesisHashShelley
genesisHash = Hash Blake2b_256 ByteString -> GenesisHashShelley
GenesisHashShelley ((ByteString -> ByteString)
-> ByteString -> Hash Blake2b_256 ByteString
forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Cardano.Crypto.Hash.Class.hashWith ByteString -> ByteString
forall a. a -> a
id ByteString
content)
    GenesisHashShelley -> ExceptT ShelleyGenesisError IO ()
checkExpectedGenesisHash GenesisHashShelley
genesisHash
    ShelleyGenesis (ShelleyEra StandardCrypto)
genesis <- (FilePath -> ShelleyGenesisError)
-> ExceptT FilePath IO (ShelleyGenesis (ShelleyEra StandardCrypto))
-> ExceptT
     ShelleyGenesisError IO (ShelleyGenesis (ShelleyEra StandardCrypto))
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
firstExceptT (FilePath -> Text -> ShelleyGenesisError
ShelleyGenesisDecodeError FilePath
file (Text -> ShelleyGenesisError)
-> (FilePath -> Text) -> FilePath -> ShelleyGenesisError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack)
                  (ExceptT FilePath IO (ShelleyGenesis (ShelleyEra StandardCrypto))
 -> ExceptT
      ShelleyGenesisError
      IO
      (ShelleyGenesis (ShelleyEra StandardCrypto)))
-> (Either FilePath (ShelleyGenesis (ShelleyEra StandardCrypto))
    -> ExceptT
         FilePath IO (ShelleyGenesis (ShelleyEra StandardCrypto)))
-> Either FilePath (ShelleyGenesis (ShelleyEra StandardCrypto))
-> ExceptT
     ShelleyGenesisError IO (ShelleyGenesis (ShelleyEra StandardCrypto))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either FilePath (ShelleyGenesis (ShelleyEra StandardCrypto))
-> ExceptT FilePath IO (ShelleyGenesis (ShelleyEra StandardCrypto))
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither
                  (Either FilePath (ShelleyGenesis (ShelleyEra StandardCrypto))
 -> ExceptT
      ShelleyGenesisError
      IO
      (ShelleyGenesis (ShelleyEra StandardCrypto)))
-> Either FilePath (ShelleyGenesis (ShelleyEra StandardCrypto))
-> ExceptT
     ShelleyGenesisError IO (ShelleyGenesis (ShelleyEra StandardCrypto))
forall a b. (a -> b) -> a -> b
$ ByteString
-> Either FilePath (ShelleyGenesis (ShelleyEra StandardCrypto))
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecodeStrict' ByteString
content
    ShelleyConfig -> ExceptT ShelleyGenesisError IO ShelleyConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShelleyConfig -> ExceptT ShelleyGenesisError IO ShelleyConfig)
-> ShelleyConfig -> ExceptT ShelleyGenesisError IO ShelleyConfig
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis (ShelleyEra StandardCrypto)
-> GenesisHashShelley -> ShelleyConfig
ShelleyConfig ShelleyGenesis (ShelleyEra StandardCrypto)
genesis GenesisHashShelley
genesisHash
  where
    checkExpectedGenesisHash :: GenesisHashShelley -> ExceptT ShelleyGenesisError IO ()
    checkExpectedGenesisHash :: GenesisHashShelley -> ExceptT ShelleyGenesisError IO ()
checkExpectedGenesisHash GenesisHashShelley
actual =
      if GenesisHashShelley
actual GenesisHashShelley -> GenesisHashShelley -> Bool
forall a. Eq a => a -> a -> Bool
/= GenesisHashShelley
expectedGenesisHash
        then ShelleyGenesisError -> ExceptT ShelleyGenesisError IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
left (GenesisHashShelley -> GenesisHashShelley -> ShelleyGenesisError
ShelleyGenesisHashMismatch GenesisHashShelley
actual GenesisHashShelley
expectedGenesisHash)
        else () -> ExceptT ShelleyGenesisError IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

renderShelleyGenesisError :: ShelleyGenesisError -> Text
renderShelleyGenesisError :: ShelleyGenesisError -> Text
renderShelleyGenesisError ShelleyGenesisError
sge =
    case ShelleyGenesisError
sge of
      ShelleyGenesisReadError 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
          ]

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

      ShelleyGenesisDecodeError 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
          ]

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

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

renderAlonzoGenesisError :: AlonzoGenesisError -> Text
renderAlonzoGenesisError :: AlonzoGenesisError -> Text
renderAlonzoGenesisError AlonzoGenesisError
sge =
    case AlonzoGenesisError
sge of
      AlonzoGenesisReadError 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
          ]

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

      AlonzoGenesisDecodeError 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 :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 ByteString -> Text
renderHash :: Hash Blake2b_256 ByteString -> Text
renderHash Hash Blake2b_256 ByteString
h = ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Base16.encode (Hash Blake2b_256 ByteString -> ByteString
forall h a. Hash h a -> ByteString
Cardano.Crypto.Hash.Class.hashToBytes Hash Blake2b_256 ByteString
h)

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

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

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

-- 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
  -> Bool
  -- ^ True to validate
  ->  HFC.HardForkBlock
            (Consensus.CardanoEras Consensus.StandardCrypto)
  -> Either Text LedgerState
applyBlock' :: Env
-> LedgerState
-> Bool
-> HardForkBlock (CardanoEras StandardCrypto)
-> Either Text LedgerState
applyBlock' Env
env LedgerState
oldState Bool
enableValidation HardForkBlock (CardanoEras StandardCrypto)
block = do
  let config :: HardForkLedgerConfig (CardanoEras StandardCrypto)
config = Env -> HardForkLedgerConfig (CardanoEras StandardCrypto)
envLedgerConfig Env
env
      stateOld :: LedgerState (HardForkBlock (CardanoEras StandardCrypto))
stateOld = LedgerState
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
clsState LedgerState
oldState
  LedgerState (HardForkBlock (CardanoEras StandardCrypto))
stateNew <- if Bool
enableValidation
    then HardForkLedgerConfig (CardanoEras StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> Either
     Text (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
tickThenApply HardForkLedgerConfig (CardanoEras StandardCrypto)
config HardForkBlock (CardanoEras StandardCrypto)
block LedgerState (HardForkBlock (CardanoEras StandardCrypto))
stateOld
    else HardForkLedgerConfig (CardanoEras StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> Either
     Text (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
tickThenReapplyCheckHash HardForkLedgerConfig (CardanoEras StandardCrypto)
config HardForkBlock (CardanoEras StandardCrypto)
block LedgerState (HardForkBlock (CardanoEras StandardCrypto))
stateOld
  LedgerState -> Either Text LedgerState
forall (m :: * -> *) a. Monad m => a -> m a
return LedgerState
oldState { clsState :: LedgerState (HardForkBlock (CardanoEras StandardCrypto))
clsState = LedgerState (HardForkBlock (CardanoEras StandardCrypto))
stateNew }

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

-- Like 'Consensus.tickThenReapply' but also checks that the previous hash from
-- the block matches the head hash of the ledger state.
tickThenApply
    :: HFC.HardForkLedgerConfig
        (Consensus.CardanoEras Shelley.StandardCrypto)
    -> Consensus.CardanoBlock Consensus.StandardCrypto
    -> Shelley.LedgerState
        (HFC.HardForkBlock
            (Consensus.CardanoEras Shelley.StandardCrypto))
    -> Either Text (Shelley.LedgerState
        (HFC.HardForkBlock
            (Consensus.CardanoEras Shelley.StandardCrypto)))
tickThenApply :: HardForkLedgerConfig (CardanoEras StandardCrypto)
-> HardForkBlock (CardanoEras StandardCrypto)
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> Either
     Text (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
tickThenApply HardForkLedgerConfig (CardanoEras StandardCrypto)
cfg HardForkBlock (CardanoEras StandardCrypto)
block LedgerState (HardForkBlock (CardanoEras StandardCrypto))
lsb
  = (HardForkLedgerError (CardanoEras StandardCrypto)
 -> Either
      Text (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
-> (LedgerState (HardForkBlock (CardanoEras StandardCrypto))
    -> Either
         Text (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
-> Either
     (HardForkLedgerError (CardanoEras StandardCrypto))
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> Either
     Text (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text
-> Either
     Text (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
forall a b. a -> Either a b
Left (Text
 -> Either
      Text (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
-> (HardForkLedgerError (CardanoEras StandardCrypto) -> Text)
-> HardForkLedgerError (CardanoEras StandardCrypto)
-> Either
     Text (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack (FilePath -> Text)
-> (HardForkLedgerError (CardanoEras StandardCrypto) -> FilePath)
-> HardForkLedgerError (CardanoEras StandardCrypto)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkLedgerError (CardanoEras StandardCrypto) -> FilePath
forall a. Show a => a -> FilePath
show) LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> Either
     Text (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
forall a b. b -> Either a b
Right
  (Either
   (HardForkLedgerError (CardanoEras StandardCrypto))
   (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
 -> Either
      Text (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
-> Either
     (HardForkLedgerError (CardanoEras StandardCrypto))
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> Either
     Text (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
forall a b. (a -> b) -> a -> b
$ Except
  (HardForkLedgerError (CardanoEras StandardCrypto))
  (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> Either
     (HardForkLedgerError (CardanoEras StandardCrypto))
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
forall e a. Except e a -> Either e a
runExcept
  (Except
   (HardForkLedgerError (CardanoEras StandardCrypto))
   (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
 -> Either
      (HardForkLedgerError (CardanoEras StandardCrypto))
      (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
-> Except
     (HardForkLedgerError (CardanoEras StandardCrypto))
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
-> Either
     (HardForkLedgerError (CardanoEras StandardCrypto))
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
forall a b. (a -> b) -> a -> b
$ LedgerConfig (HardForkBlock (CardanoEras StandardCrypto))
-> HardForkBlock (CardanoEras StandardCrypto)
-> LedgerState (HardForkBlock (CardanoEras StandardCrypto))
-> Except
     (LedgerErr
        (LedgerState (HardForkBlock (CardanoEras StandardCrypto))))
     (LedgerState (HardForkBlock (CardanoEras StandardCrypto)))
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
Ledger.tickThenApply LedgerConfig (HardForkBlock (CardanoEras StandardCrypto))
HardForkLedgerConfig (CardanoEras StandardCrypto)
cfg HardForkBlock (CardanoEras StandardCrypto)
block LedgerState (HardForkBlock (CardanoEras StandardCrypto))
lsb

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

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