1
{-# LANGUAGE DataKinds #-}
2
{-# LANGUAGE DerivingStrategies #-}
4
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5
{-# LANGUAGE LambdaCase #-}
6
{-# LANGUAGE PatternSynonyms #-}
7
{-# LANGUAGE RankNTypes #-}
8
{-# LANGUAGE ScopedTypeVariables #-}
10
module Cardano.Api.LedgerState
11
( -- * Initialization / Accumulation
24
-- * Traversing the block chain
29
, GenesisConfigError(..)
30
, InitialLedgerStateError(..)
31
, renderFoldBlocksError
32
, renderGenesisConfigError
33
, renderInitialLedgerStateError
39
import Control.Exception
40
import Control.Monad.Trans.Class
41
import Control.Monad.Trans.Except
42
import Control.Monad.Trans.Except.Extra
43
import Data.Aeson as Aeson
44
import qualified Data.Aeson.Types as Data.Aeson.Types.Internal
45
import Data.ByteArray (ByteArrayAccess)
46
import qualified Data.ByteArray
47
import Data.ByteString as BS
48
import qualified Data.ByteString.Base16 as Base16
49
import Data.ByteString.Short as BSS
52
import Data.Sequence (Seq)
53
import qualified Data.Sequence as Seq
54
import Data.Text (Text)
55
import qualified Data.Text as Text
56
import qualified Data.Text.Encoding as Text
58
import qualified Data.Yaml as Yaml
59
import System.FilePath
61
import Cardano.Api.Block
62
import Cardano.Api.Eras
63
import Cardano.Api.IPC (ConsensusModeParams (CardanoModeParams), EpochSlots (..),
64
LocalChainSyncClient (LocalChainSyncClientPipelined),
65
LocalNodeClientProtocols (..), LocalNodeClientProtocolsInMode,
66
LocalNodeConnectInfo (..), connectToLocalNode)
67
import Cardano.Api.Modes (CardanoMode)
68
import Cardano.Api.NetworkId (NetworkId)
69
import qualified Cardano.Chain.Genesis
70
import qualified Cardano.Chain.Update
71
import qualified Cardano.Crypto
72
import qualified Cardano.Crypto.Hash.Blake2b
73
import qualified Cardano.Crypto.Hash.Class
74
import qualified Cardano.Crypto.Hashing
75
import qualified Cardano.Crypto.ProtocolMagic
76
import Cardano.Slotting.Slot (WithOrigin (At, Origin))
77
import qualified Cardano.Slotting.Slot as Slot
78
import Network.TypedProtocol.Pipelined (Nat (..))
79
import qualified Ouroboros.Consensus.Block.Abstract as Consensus
80
import qualified Ouroboros.Consensus.Byron.Ledger.Block as Byron
81
import qualified Ouroboros.Consensus.Cardano as Consensus
82
import qualified Ouroboros.Consensus.Cardano.Block as Consensus
83
import qualified Ouroboros.Consensus.Cardano.CanHardFork as Consensus
84
import qualified Ouroboros.Consensus.Cardano.Node as Consensus
85
import qualified Ouroboros.Consensus.Config as Consensus
86
import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as HFC
87
import qualified Ouroboros.Consensus.HardFork.Combinator.Basics as HFC
88
import qualified Ouroboros.Consensus.Ledger.Abstract as Ledger
89
import qualified Ouroboros.Consensus.Ledger.Extended as Ledger
90
import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus
91
import qualified Ouroboros.Consensus.Shelley.Eras as Shelley
92
import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Shelley
93
import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Shelley
94
import qualified Ouroboros.Consensus.Shelley.Protocol as Shelley
95
import qualified Ouroboros.Network.Block
96
import Ouroboros.Network.Protocol.ChainSync.ClientPipelined
97
(ChainSyncClientPipelined (ChainSyncClientPipelined),
98
ClientPipelinedStIdle (CollectResponse, SendMsgDone, SendMsgRequestNextPipelined),
100
import Ouroboros.Network.Protocol.ChainSync.PipelineDecision
101
import qualified Shelley.Spec.Ledger.BaseTypes as Shelley.Spec
102
import qualified Shelley.Spec.Ledger.Credential as Shelley.Spec
103
import qualified Shelley.Spec.Ledger.Genesis as Shelley.Spec
104
import qualified Shelley.Spec.Ledger.Keys as Shelley.Spec
105
import qualified Shelley.Spec.Ledger.PParams as Shelley.Spec
107
data InitialLedgerStateError
108
= ILSEConfigFile Text
109
-- ^ Failed to read or parse the network config file.
110
| ILSEGenesisFile GenesisConfigError
111
-- ^ Failed to read or parse a genesis file linked from the network config file.
112
| ILSELedgerConsensusConfig GenesisConfigError
113
-- ^ Failed to derive the Ledger or Consensus config.
115
renderInitialLedgerStateError :: InitialLedgerStateError -> Text
116
renderInitialLedgerStateError ilse = case ilse of
117
ILSEConfigFile err ->
118
"Failed to read or parse the network config file: " <> err
119
ILSEGenesisFile err ->
120
"Failed to read or parse a genesis file linked from the network config file: "
121
<> renderGenesisConfigError err
122
ILSELedgerConsensusConfig err ->
123
"Failed to derive the Ledger or Consensus config: "
124
<> renderGenesisConfigError err
126
-- | Get the environment and initial ledger state.
129
-- ^ Path to the cardano-node config file (e.g. <path to cardano-node project>/configuration/cardano/mainnet-config.json)
130
-> ExceptT InitialLedgerStateError IO (Env, LedgerState)
131
-- ^ The environment and initial ledger state
132
initialLedgerState networkConfigFile = do
133
-- TODO Once support for querying the ledger config is added to the node, we
134
-- can remove the networkConfigFile argument and much of the code in this
136
config <- withExceptT ILSEConfigFile
137
(readNetworkConfig (NetworkConfigFile networkConfigFile))
138
genesisConfig <- withExceptT ILSEGenesisFile (readCardanoGenesisConfig config)
139
env <- withExceptT ILSELedgerConsensusConfig (except (genesisConfigToEnv genesisConfig))
140
let ledgerState = initLedgerStateVar genesisConfig
141
return (env, ledgerState)
143
-- | Apply a single block to the current ledger state.
146
-- ^ The environment returned by @initialLedgerState@
148
-- ^ The current ledger state
150
-- ^ True to perform validation. If True, `tickThenApply` will be used instead
151
-- of `tickThenReapply`.
153
-- ^ Some block to apply
154
-> Either Text LedgerState
155
-- ^ The new ledger state (or an error).
156
applyBlock env oldState enableValidation block
157
= applyBlock' env oldState enableValidation $ case block of
158
ByronBlock byronBlock -> Consensus.BlockByron byronBlock
159
ShelleyBlock blockEra shelleyBlock -> case blockEra of
160
ShelleyBasedEraShelley -> Consensus.BlockShelley shelleyBlock
161
ShelleyBasedEraAllegra -> Consensus.BlockAllegra shelleyBlock
162
ShelleyBasedEraMary -> Consensus.BlockMary shelleyBlock
164
pattern LedgerStateByron
165
:: Ledger.LedgerState Byron.ByronBlock
167
pattern LedgerStateByron st <- LedgerState (Consensus.LedgerStateByron st)
169
pattern LedgerStateShelley
170
:: Ledger.LedgerState (Shelley.ShelleyBlock (Shelley.ShelleyEra Shelley.StandardCrypto))
172
pattern LedgerStateShelley st <- LedgerState (Consensus.LedgerStateShelley st)
174
pattern LedgerStateAllegra
175
:: Ledger.LedgerState (Shelley.ShelleyBlock (Shelley.AllegraEra Shelley.StandardCrypto))
177
pattern LedgerStateAllegra st <- LedgerState (Consensus.LedgerStateAllegra st)
179
pattern LedgerStateMary
180
:: Ledger.LedgerState (Shelley.ShelleyBlock (Shelley.MaryEra Shelley.StandardCrypto))
182
pattern LedgerStateMary st <- LedgerState (Consensus.LedgerStateMary st)
184
{-# COMPLETE LedgerStateByron
187
, LedgerStateMary #-}
190
= FoldBlocksInitialLedgerStateError InitialLedgerStateError
191
| FoldBlocksApplyBlockError Text
193
renderFoldBlocksError :: FoldBlocksError -> Text
194
renderFoldBlocksError fbe = case fbe of
195
FoldBlocksInitialLedgerStateError err -> renderInitialLedgerStateError err
196
FoldBlocksApplyBlockError err -> "Failed when applying a block: " <> err
198
-- | Monadic fold over all blocks and ledger states. Stopping @k@ blocks before
199
-- the node's tip where @k@ is the security parameter.
203
-- ^ Path to the cardano-node config file (e.g. <path to cardano-node project>/configuration/cardano/mainnet-config.json)
205
-- ^ Path to local cardano-node socket. This is the path specified by the @--socket-path@ command line option when running the node.
209
-- ^ True to enable validation. Under the hood this will use @applyBlock@
210
-- instead of @reapplyBlock@ from the @ApplyBlock@ type class.
212
-- ^ The initial accumulator state.
213
-> (Env -> LedgerState -> BlockInMode CardanoMode -> a -> IO a)
214
-- ^ Accumulator function Takes:
215
-- * Environment (this is a constant over the whole fold)
216
-- * The current Ledger state (with the current block applied)
217
-- * The current Block
218
-- * The previous state
220
-- And this should return the new state.
222
-- Note: This function can safely assume no rollback will occur even though
223
-- internally this is implemented with a client protocol that may require
224
-- rollback. This is achieved by only calling the accumulator on states/blocks
225
-- that are older than the security parameter, k. This has the side effect of
226
-- truncating the last k blocks before the node's tip.
227
-> ExceptT FoldBlocksError IO a
229
foldBlocks nodeConfigFilePath socketPath networkId enableValidation state0 accumulate = do
230
-- NOTE this was originally implemented with a non-pipelined client then
231
-- changed to a pipelined client for a modest speedup:
232
-- * Non-pipelined: 1h 0m 19s
233
-- * Pipelined: 46m 23s
235
(env, ledgerState) <- withExceptT FoldBlocksInitialLedgerStateError
236
(initialLedgerState nodeConfigFilePath)
238
-- Place to store the accumulated state
239
-- This is a bit ugly, but easy.
240
errorIORef <- lift $ newIORef Nothing
241
stateIORef <- lift $ newIORef state0
243
-- Connect to the node.
244
lift $ connectToLocalNode
246
(protocols stateIORef errorIORef env ledgerState)
248
lift (readIORef errorIORef) >>= \case
249
Just err -> throwE (FoldBlocksApplyBlockError err)
250
Nothing -> lift $ readIORef stateIORef
252
connectInfo :: LocalNodeConnectInfo CardanoMode
254
LocalNodeConnectInfo {
255
localConsensusModeParams = CardanoModeParams (EpochSlots 21600),
256
localNodeNetworkId = networkId,
257
localNodeSocketPath = socketPath
260
protocols :: IORef a -> IORef (Maybe Text) -> Env -> LedgerState -> LocalNodeClientProtocolsInMode CardanoMode
261
protocols stateIORef errorIORef env ledgerState =
262
LocalNodeClientProtocols {
263
localChainSyncClient = LocalChainSyncClientPipelined (chainSyncClient 50 stateIORef errorIORef env ledgerState),
264
localTxSubmissionClient = Nothing,
265
localStateQueryClient = Nothing
268
-- | Add a new ledger state to the history
270
:: Env -- ^ Environement used to get the security param, k.
271
-> LedgerStateHistory -- ^ History of k ledger states.
272
-> SlotNo -- ^ Slot number of the new ledger state.
273
-> LedgerState -- ^ New ledger state to add to the history
274
-> BlockInMode CardanoMode
275
-- ^ The block that (when applied to the previous
276
-- ledger state) resulted in the new ledger state.
277
-> (LedgerStateHistory, LedgerStateHistory)
278
-- ^ ( The new history with the new state appended
279
-- , Any exisiting ledger states that are now past the security parameter
280
-- and hence can no longer be rolled back.
282
pushLedgerState env hist ix st block
284
(fromIntegral $ envSecurityParam env + 1)
285
((ix, st, At block) Seq.:<| hist)
287
rollBackLedgerStateHist :: LedgerStateHistory -> SlotNo -> LedgerStateHistory
288
rollBackLedgerStateHist hist maxInc = Seq.dropWhileL ((> maxInc) . (\(x,_,_) -> x)) hist
290
-- | Defines the client side of the chain sync protocol.
291
chainSyncClient :: Word32
292
-- ^ The maximum number of concurrent requests.
294
-> IORef (Maybe Text)
295
-- ^ Resulting error if any. Written to once on protocol
299
-> ChainSyncClientPipelined
300
(BlockInMode CardanoMode)
304
-- ^ Client returns maybe an error.
305
chainSyncClient pipelineSize stateIORef errorIORef env ledgerState0
306
= ChainSyncClientPipelined $ pure $ clientIdle_RequestMoreN Origin Origin Zero initialLedgerStateHistory
308
initialLedgerStateHistory = Seq.singleton (0, ledgerState0, Origin)
310
pushLedgerState' = pushLedgerState env
312
clientIdle_RequestMoreN
313
:: WithOrigin BlockNo
314
-> WithOrigin BlockNo
315
-> Nat n -- Number of requests inflight.
316
-> LedgerStateHistory
317
-> ClientPipelinedStIdle n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
318
clientIdle_RequestMoreN clientTip serverTip n knownLedgerStates
319
= case pipelineDecisionMax pipelineSize n clientTip serverTip of
321
Succ predN -> CollectResponse Nothing (clientNextN predN knownLedgerStates)
322
_ -> SendMsgRequestNextPipelined (clientIdle_RequestMoreN clientTip serverTip (Succ n) knownLedgerStates)
325
:: Nat n -- Number of requests inflight.
326
-> LedgerStateHistory
327
-> ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
328
clientNextN n knownLedgerStates =
330
recvMsgRollForward = \blockInMode@(BlockInMode block@(Block (BlockHeader slotNo _ currBlockNo) _) _era) serverChainTip -> do
331
let newLedgerStateE = applyBlock
334
(error "Impossible! Missing Ledger state")
336
(Seq.lookup 0 knownLedgerStates)
340
case newLedgerStateE of
341
Left err -> clientIdle_DoneN n (Just err)
342
Right newLedgerState -> do
343
let (knownLedgerStates', committedStates) = pushLedgerState' knownLedgerStates slotNo newLedgerState blockInMode
344
newClientTip = At currBlockNo
345
newServerTip = fromChainTip serverChainTip
346
forM_ committedStates $ \(_, currLedgerState, currBlockMay) -> case currBlockMay of
349
newState <- accumulate env currLedgerState currBlock =<< readIORef stateIORef
350
writeIORef stateIORef newState
351
if newClientTip == newServerTip
352
then clientIdle_DoneN n Nothing
353
else return (clientIdle_RequestMoreN newClientTip newServerTip n knownLedgerStates')
354
, recvMsgRollBackward = \chainPoint serverChainTip -> do
355
let newClientTip = Origin -- We don't actually keep track of blocks so we temporarily "forget" the tip.
356
newServerTip = fromChainTip serverChainTip
357
truncatedKnownLedgerStates = case chainPoint of
358
ChainPointAtGenesis -> initialLedgerStateHistory
359
ChainPoint slotNo _ -> rollBackLedgerStateHist knownLedgerStates slotNo
360
return (clientIdle_RequestMoreN newClientTip newServerTip n truncatedKnownLedgerStates)
364
:: Nat n -- Number of requests inflight.
365
-> Maybe Text -- Return value (maybe an error)
366
-> IO (ClientPipelinedStIdle n (BlockInMode CardanoMode) ChainPoint ChainTip IO ())
367
clientIdle_DoneN n errorMay = case n of
368
Succ predN -> return (CollectResponse Nothing (clientNext_DoneN predN errorMay)) -- Ignore remaining message responses
370
writeIORef errorIORef errorMay
371
return (SendMsgDone ())
374
:: Nat n -- Number of requests inflight.
375
-> Maybe Text -- Return value (maybe an error)
376
-> ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()
377
clientNext_DoneN n errorMay =
379
recvMsgRollForward = \_ _ -> clientIdle_DoneN n errorMay
380
, recvMsgRollBackward = \_ _ -> clientIdle_DoneN n errorMay
383
fromChainTip :: ChainTip -> WithOrigin BlockNo
384
fromChainTip ct = case ct of
385
ChainTipAtGenesis -> Origin
386
ChainTip _ _ bno -> At bno
388
-- | A history of k (security parameter) recent ledger states. The head is the
389
-- most recent item. Elements are:
391
-- * Slot number that a new block occurred
392
-- * The ledger state after applying the new block
395
type LedgerStateHistory = Seq (SlotNo, LedgerState, WithOrigin (BlockInMode CardanoMode))
397
--------------------------------------------------------------------------------
398
-- Everything below was copied/adapted from db-sync --
399
--------------------------------------------------------------------------------
403
-> Either GenesisConfigError Env
408
GenesisCardano _ bCfg sCfg
409
| Cardano.Crypto.ProtocolMagic.unProtocolMagicId (Cardano.Chain.Genesis.configProtocolMagicId bCfg) /= Shelley.Spec.sgNetworkMagic (scConfig sCfg) ->
410
Left . NECardanoConfig $
412
[ "ProtocolMagicId ", textShow (Cardano.Crypto.ProtocolMagic.unProtocolMagicId $ Cardano.Chain.Genesis.configProtocolMagicId bCfg)
413
, " /= ", textShow (Shelley.Spec.sgNetworkMagic $ scConfig sCfg)
415
| Cardano.Chain.Genesis.gdStartTime (Cardano.Chain.Genesis.configGenesisData bCfg) /= Shelley.Spec.sgSystemStart (scConfig sCfg) ->
416
Left . NECardanoConfig $
418
[ "SystemStart ", textShow (Cardano.Chain.Genesis.gdStartTime $ Cardano.Chain.Genesis.configGenesisData bCfg)
419
, " /= ", textShow (Shelley.Spec.sgSystemStart $ scConfig sCfg)
423
topLevelConfig = Consensus.pInfoConfig (mkProtocolInfoCardano genCfg)
426
{ envLedgerConfig = Consensus.topLevelConfigLedger topLevelConfig
427
, envProtocolConfig = Consensus.topLevelConfigProtocol topLevelConfig
430
readNetworkConfig :: NetworkConfigFile -> ExceptT Text IO NodeConfig
431
readNetworkConfig (NetworkConfigFile ncf) = do
432
ncfg <- (except . parseNodeConfig) =<< readByteString ncf "node"
434
{ ncByronGenesisFile = adjustGenesisFilePath (mkAdjustPath ncf) (ncByronGenesisFile ncfg)
435
, ncShelleyGenesisFile = adjustGenesisFilePath (mkAdjustPath ncf) (ncShelleyGenesisFile ncfg)
438
data NodeConfig = NodeConfig
439
{ ncPBftSignatureThreshold :: !(Maybe Double)
440
, ncByronGenesisFile :: !GenesisFile
441
, ncByronGenesisHash :: !GenesisHashByron
442
, ncShelleyGenesisFile :: !GenesisFile
443
, ncShelleyGenesisHash :: !GenesisHashShelley
444
, ncRequiresNetworkMagic :: !Cardano.Crypto.RequiresNetworkMagic
445
, ncByronSoftwareVersion :: !Cardano.Chain.Update.SoftwareVersion
446
, ncByronProtocolVersion :: !Cardano.Chain.Update.ProtocolVersion
448
-- Shelley hardfok parameters
449
, ncByronToShelley :: !ByronToShelley
451
-- Allegra hardfok parameters
452
, ncShelleyToAllegra :: !ShelleyToAllegra
454
-- Mary hardfok parameters
455
, ncAllegraToMary :: !AllegraToMary
458
instance FromJSON NodeConfig where
460
Aeson.withObject "NodeConfig" parse v
462
parse :: Object -> Data.Aeson.Types.Internal.Parser NodeConfig
465
<$> o .:? "PBftSignatureThreshold"
466
<*> fmap GenesisFile (o .: "ByronGenesisFile")
467
<*> fmap GenesisHashByron (o .: "ByronGenesisHash")
468
<*> fmap GenesisFile (o .: "ShelleyGenesisFile")
469
<*> fmap GenesisHashShelley (o .: "ShelleyGenesisHash")
470
<*> o .: "RequiresNetworkMagic"
471
<*> parseByronSoftwareVersion o
472
<*> parseByronProtocolVersion o
473
<*> (Consensus.ProtocolParamsTransition <$> parseShelleyHardForkEpoch o)
474
<*> (Consensus.ProtocolParamsTransition <$> parseAllegraHardForkEpoch o)
475
<*> (Consensus.ProtocolParamsTransition <$> parseMaryHardForkEpoch o)
477
parseByronProtocolVersion :: Object -> Data.Aeson.Types.Internal.Parser Cardano.Chain.Update.ProtocolVersion
478
parseByronProtocolVersion o =
479
Cardano.Chain.Update.ProtocolVersion
480
<$> o .: "LastKnownBlockVersion-Major"
481
<*> o .: "LastKnownBlockVersion-Minor"
482
<*> o .: "LastKnownBlockVersion-Alt"
484
parseByronSoftwareVersion :: Object -> Data.Aeson.Types.Internal.Parser Cardano.Chain.Update.SoftwareVersion
485
parseByronSoftwareVersion o =
486
Cardano.Chain.Update.SoftwareVersion
487
<$> fmap Cardano.Chain.Update.ApplicationName (o .: "ApplicationName")
488
<*> o .: "ApplicationVersion"
490
parseShelleyHardForkEpoch :: Object -> Data.Aeson.Types.Internal.Parser Consensus.TriggerHardFork
491
parseShelleyHardForkEpoch o =
493
[ Consensus.TriggerHardForkAtEpoch <$> o .: "TestShelleyHardForkAtEpoch"
494
, pure $ Consensus.TriggerHardForkAtVersion 2 -- Mainnet default
497
parseAllegraHardForkEpoch :: Object -> Data.Aeson.Types.Internal.Parser Consensus.TriggerHardFork
498
parseAllegraHardForkEpoch o =
500
[ Consensus.TriggerHardForkAtEpoch <$> o .: "TestAllegraHardForkAtEpoch"
501
, pure $ Consensus.TriggerHardForkAtVersion 3 -- Mainnet default
504
parseMaryHardForkEpoch :: Object -> Data.Aeson.Types.Internal.Parser Consensus.TriggerHardFork
505
parseMaryHardForkEpoch o =
507
[ Consensus.TriggerHardForkAtEpoch <$> o .: "TestMaryHardForkAtEpoch"
508
, pure $ Consensus.TriggerHardForkAtVersion 4 -- Mainnet default
511
parseNodeConfig :: ByteString -> Either Text NodeConfig
513
case Yaml.decodeEither' bs of
514
Left err -> Left $ "Error parsing node config: " <> textShow err
517
adjustGenesisFilePath :: (FilePath -> FilePath) -> GenesisFile -> GenesisFile
518
adjustGenesisFilePath f (GenesisFile p) = GenesisFile (f p)
520
mkAdjustPath :: FilePath -> (FilePath -> FilePath)
521
mkAdjustPath nodeConfigFilePath fp = takeDirectory nodeConfigFilePath </> fp
523
readByteString :: FilePath -> Text -> ExceptT Text IO ByteString
524
readByteString fp cfgType = ExceptT $
525
catch (Right <$> BS.readFile fp) $ \(_ :: IOException) ->
526
return $ Left $ mconcat
527
[ "Cannot read the ", cfgType, " configuration file at : ", Text.pack fp ]
529
initLedgerStateVar :: GenesisConfig -> LedgerState
530
initLedgerStateVar genesisConfig = LedgerState
531
{ clsState = Ledger.ledgerState $ Consensus.pInfoInitLedger protocolInfo
534
protocolInfo = mkProtocolInfoCardano genesisConfig
536
newtype LedgerState = LedgerState
537
{ clsState :: Ledger.LedgerState
539
(Consensus.CardanoEras Consensus.StandardCrypto))
542
-- Usually only one constructor, but may have two when we are preparing for a HFC event.
544
= GenesisCardano !NodeConfig !Cardano.Chain.Genesis.Config !ShelleyConfig
546
data ShelleyConfig = ShelleyConfig
547
{ scConfig :: !(Shelley.Spec.ShelleyGenesis Shelley.StandardShelley)
548
, scGenesisHash :: !GenesisHashShelley
551
type ByronToShelley =
552
Consensus.ProtocolParamsTransition Byron.ByronBlock
553
(Shelley.ShelleyBlock Shelley.StandardShelley)
555
type ShelleyToAllegra =
556
Consensus.ProtocolParamsTransition
557
(Shelley.ShelleyBlock Shelley.StandardShelley)
558
(Shelley.ShelleyBlock Shelley.StandardAllegra)
561
Consensus.ProtocolParamsTransition
562
(Shelley.ShelleyBlock Shelley.StandardAllegra)
563
(Shelley.ShelleyBlock Shelley.StandardMary)
565
newtype GenesisFile = GenesisFile
566
{ unGenesisFile :: FilePath
569
newtype GenesisHashByron = GenesisHashByron
570
{ unGenesisHashByron :: Text
571
} deriving newtype (Eq, Show)
573
newtype GenesisHashShelley = GenesisHashShelley
574
{ unGenesisHashShelley :: Cardano.Crypto.Hash.Class.Hash Cardano.Crypto.Hash.Blake2b.Blake2b_256 ByteString
575
} deriving newtype (Eq, Show)
577
newtype LedgerStateDir = LedgerStateDir
578
{ unLedgerStateDir :: FilePath
581
newtype NetworkName = NetworkName
582
{ unNetworkName :: Text
585
newtype NetworkConfigFile = NetworkConfigFile
586
{ unNetworkConfigFile :: FilePath
589
newtype SocketPath = SocketPath
590
{ unSocketPath :: FilePath
593
mkProtocolInfoCardano ::
595
Consensus.ProtocolInfo
598
(Consensus.CardanoEras Consensus.StandardCrypto))
599
mkProtocolInfoCardano (GenesisCardano dnc byronGenesis shelleyGenesis)
600
= Consensus.protocolInfoCardano
601
Consensus.ProtocolParamsByron
602
{ Consensus.byronGenesis = byronGenesis
603
, Consensus.byronPbftSignatureThreshold = Consensus.PBftSignatureThreshold <$> ncPBftSignatureThreshold dnc
604
, Consensus.byronProtocolVersion = ncByronProtocolVersion dnc
605
, Consensus.byronSoftwareVersion = ncByronSoftwareVersion dnc
606
, Consensus.byronLeaderCredentials = Nothing
608
Consensus.ProtocolParamsShelleyBased
609
{ Consensus.shelleyBasedGenesis = scConfig shelleyGenesis
610
, Consensus.shelleyBasedInitialNonce = shelleyPraosNonce shelleyGenesis
611
, Consensus.shelleyBasedLeaderCredentials = []
613
Consensus.ProtocolParamsShelley
614
{ Consensus.shelleyProtVer = shelleyProtVer dnc
616
Consensus.ProtocolParamsAllegra
617
{ Consensus.allegraProtVer = shelleyProtVer dnc
619
Consensus.ProtocolParamsMary
620
{ Consensus.maryProtVer = shelleyProtVer dnc
622
(ncByronToShelley dnc)
623
(ncShelleyToAllegra dnc)
624
(ncAllegraToMary dnc)
626
shelleyPraosNonce :: ShelleyConfig -> Shelley.Spec.Nonce
627
shelleyPraosNonce sCfg = Shelley.Spec.Nonce (Cardano.Crypto.Hash.Class.castHash . unGenesisHashShelley $ scGenesisHash sCfg)
629
shelleyProtVer :: NodeConfig -> Shelley.Spec.ProtVer
631
let bver = ncByronProtocolVersion dnc in
633
(fromIntegral $ Cardano.Chain.Update.pvMajor bver)
634
(fromIntegral $ Cardano.Chain.Update.pvMinor bver)
636
readCardanoGenesisConfig
638
-> ExceptT GenesisConfigError IO GenesisConfig
639
readCardanoGenesisConfig enc =
640
GenesisCardano enc <$> readByronGenesisConfig enc <*> readShelleyGenesisConfig enc
642
data GenesisConfigError
644
| NEByronConfig !FilePath !Cardano.Chain.Genesis.ConfigurationError
645
| NEShelleyConfig !FilePath !Text
646
| NECardanoConfig !Text
648
renderGenesisConfigError :: GenesisConfigError -> Text
649
renderGenesisConfigError ne =
651
NEError t -> "Error: " <> t
652
NEByronConfig fp ce ->
654
[ "Failed reading Byron genesis file ", textShow fp, ": ", textShow ce
656
NEShelleyConfig fp txt ->
658
[ "Failed reading Shelley genesis file ", textShow fp, ": ", txt
660
NECardanoConfig err ->
662
[ "With Cardano protocol, Byron/Shelley config mismatch:\n"
667
= DbLookupBlockHash !ByteString
668
| DbLookupBlockId !Word64
669
| DbLookupMessage !Text
670
| DbLookupTxHash !ByteString
671
| DbLookupTxOutPair !ByteString !Word16
672
| DbLookupEpochNo !Word64
673
| DbLookupSlotNo !Word64
678
readByronGenesisConfig
680
-> ExceptT GenesisConfigError IO Cardano.Chain.Genesis.Config
681
readByronGenesisConfig enc = do
682
let file = unGenesisFile $ ncByronGenesisFile enc
683
genHash <- firstExceptT NEError
685
$ Cardano.Crypto.Hashing.decodeAbstractHash (unGenesisHashByron $ ncByronGenesisHash enc)
686
firstExceptT (NEByronConfig file)
687
$ Cardano.Chain.Genesis.mkConfigFromFile (ncRequiresNetworkMagic enc) file genHash
689
readShelleyGenesisConfig
691
-> ExceptT GenesisConfigError IO ShelleyConfig
692
readShelleyGenesisConfig enc = do
693
let file = unGenesisFile $ ncShelleyGenesisFile enc
694
firstExceptT (NEShelleyConfig file . renderShelleyGenesisError)
695
$ readGenesis (GenesisFile file) (ncShelleyGenesisHash enc)
697
textShow :: Show a => a -> Text
698
textShow = Text.pack . show
701
:: GenesisFile -> GenesisHashShelley
702
-> ExceptT ShelleyGenesisError IO ShelleyConfig
703
readGenesis (GenesisFile file) expectedGenesisHash = do
704
content <- handleIOExceptT (GenesisReadError file . textShow) $ BS.readFile file
705
let genesisHash = GenesisHashShelley (Cardano.Crypto.Hash.Class.hashWith id content)
706
checkExpectedGenesisHash genesisHash
707
genesis <- firstExceptT (GenesisDecodeError file . Text.pack)
709
$ Aeson.eitherDecodeStrict' content
710
pure $ ShelleyConfig genesis genesisHash
712
checkExpectedGenesisHash :: GenesisHashShelley -> ExceptT ShelleyGenesisError IO ()
713
checkExpectedGenesisHash actual =
714
if actual /= expectedGenesisHash
715
then left (GenesisHashMismatch actual expectedGenesisHash)
718
data ShelleyGenesisError
719
= GenesisReadError !FilePath !Text
720
| GenesisHashMismatch !GenesisHashShelley !GenesisHashShelley -- actual, expected
721
| GenesisDecodeError !FilePath !Text
724
renderShelleyGenesisError :: ShelleyGenesisError -> Text
725
renderShelleyGenesisError sge =
727
GenesisReadError fp err ->
729
[ "There was an error reading the genesis file: ", Text.pack fp
733
GenesisHashMismatch actual expected ->
735
[ "Wrong Shelley genesis file: the actual hash is ", renderHash actual
736
, ", but the expected Shelley genesis hash given in the node "
737
, "configuration file is ", renderHash expected, "."
740
GenesisDecodeError fp err ->
742
[ "There was an error parsing the genesis file: ", Text.pack fp
746
renderHash :: GenesisHashShelley -> Text
747
renderHash (GenesisHashShelley h) = Text.decodeUtf8 $ Base16.encode (Cardano.Crypto.Hash.Class.hashToBytes h)
750
= StakeCred { _unStakeCred :: Shelley.Spec.Credential 'Shelley.Spec.Staking Consensus.StandardCrypto }
754
{ envLedgerConfig :: HFC.HardForkLedgerConfig (Consensus.CardanoEras Shelley.StandardCrypto)
755
, envProtocolConfig :: Shelley.ConsensusConfig (HFC.HardForkProtocol (Consensus.CardanoEras Shelley.StandardCrypto))
758
envSecurityParam :: Env -> Word64
759
envSecurityParam env = k
761
Consensus.SecurityParam k
762
= HFC.hardForkConsensusConfigK
763
$ envProtocolConfig env
765
-- The function 'tickThenReapply' does zero validation, so add minimal
766
-- validation ('blockPrevHash' matches the tip hash of the 'LedgerState'). This
767
-- was originally for debugging but the check is cheap enough to keep.
772
-- ^ True to validate
774
(Consensus.CardanoEras Consensus.StandardCrypto)
775
-> Either Text LedgerState
776
applyBlock' env oldState enableValidation block = do
777
let config = envLedgerConfig env
778
stateOld = clsState oldState
779
stateNew <- if enableValidation
780
then tickThenApply config block stateOld
781
else tickThenReapplyCheckHash config block stateOld
782
return oldState { clsState = stateNew }
784
-- Like 'Consensus.tickThenReapply' but also checks that the previous hash from
785
-- the block matches the head hash of the ledger state.
786
tickThenReapplyCheckHash
787
:: HFC.HardForkLedgerConfig
788
(Consensus.CardanoEras Shelley.StandardCrypto)
789
-> Consensus.CardanoBlock Consensus.StandardCrypto
790
-> Shelley.LedgerState
792
(Consensus.CardanoEras Shelley.StandardCrypto))
793
-> Either Text (Shelley.LedgerState
795
(Consensus.CardanoEras Shelley.StandardCrypto)))
796
tickThenReapplyCheckHash cfg block lsb =
797
if Consensus.blockPrevHash block == Ledger.ledgerTipHash lsb
798
then Right $ Ledger.tickThenReapply cfg block lsb
800
[ "Ledger state hash mismatch. Ledger head is slot "
803
$ Slot.fromWithOrigin
805
(Ledger.ledgerTipSlot lsb)
809
$ Ledger.ledgerTipHash lsb
810
, " but block previous hash is "
811
, renderByteArray (unChainHash $ Consensus.blockPrevHash block)
812
, " and block current hash is "
816
$ Ouroboros.Network.Block.blockHash block
820
-- Like 'Consensus.tickThenReapply' but also checks that the previous hash from
821
-- the block matches the head hash of the ledger state.
823
:: HFC.HardForkLedgerConfig
824
(Consensus.CardanoEras Shelley.StandardCrypto)
825
-> Consensus.CardanoBlock Consensus.StandardCrypto
826
-> Shelley.LedgerState
828
(Consensus.CardanoEras Shelley.StandardCrypto))
829
-> Either Text (Shelley.LedgerState
831
(Consensus.CardanoEras Shelley.StandardCrypto)))
832
tickThenApply cfg block lsb
833
= either (Left . Text.pack . show) Right
835
$ Ledger.tickThenApply cfg block lsb
837
renderByteArray :: ByteArrayAccess bin => bin -> Text
839
Text.decodeUtf8 . Base16.encode . Data.ByteArray.convert
841
unChainHash :: Ouroboros.Network.Block.ChainHash (Consensus.CardanoBlock era) -> ByteString
844
Ouroboros.Network.Block.GenesisHash -> "genesis"
845
Ouroboros.Network.Block.BlockHash bh -> BSS.fromShort (HFC.getOneEraHash bh)
added
removed
cardano-api/src/Cardano/Api/LedgerState.hs
