-
Notifications
You must be signed in to change notification settings - Fork 20
/
Config.hs
139 lines (126 loc) · 5.58 KB
/
Config.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.Shelley.Ledger.Config (
BlockConfig (..)
, CodecConfig (..)
, StorageConfig (..)
, compactGenesis
, getCompactGenesis
, mkShelleyBlockConfig
-- * opaque
, CompactGenesis
) where
import Cardano.Ledger.Binary (FromCBOR, ToCBOR)
import Cardano.Ledger.Crypto (Crypto)
import qualified Cardano.Ledger.Shelley.API as SL
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Word (Word64)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Protocol.Praos.Common
(VRFTiebreakerFlavor (..))
import Ouroboros.Consensus.Shelley.Eras (EraCrypto, isBeforeConway)
import Ouroboros.Consensus.Shelley.Ledger.Block
import Ouroboros.Network.Magic (NetworkMagic (..))
{-------------------------------------------------------------------------------
Additional node configuration
-------------------------------------------------------------------------------}
data instance BlockConfig (ShelleyBlock proto era) = ShelleyConfig {
-- | The highest protocol version this node supports. It will be stored
-- the headers of produced blocks.
shelleyProtocolVersion :: !SL.ProtVer
, shelleySystemStart :: !SystemStart
, shelleyNetworkMagic :: !NetworkMagic
-- | For nodes that can produce blocks, this should be set to the
-- verification key(s) corresponding to the node's signing key(s). For non
-- block producing nodes, this can be set to the empty map.
, shelleyBlockIssuerVKeys :: !(Map (SL.KeyHash 'SL.BlockIssuer (EraCrypto era))
(SL.VKey 'SL.BlockIssuer (EraCrypto era)))
, shelleyVRFTiebreakerFlavor :: !VRFTiebreakerFlavor
}
deriving stock (Generic)
deriving instance ShelleyBasedEra era => Show (BlockConfig (ShelleyBlock proto era))
deriving instance ShelleyBasedEra era => NoThunks (BlockConfig (ShelleyBlock proto era))
mkShelleyBlockConfig ::
forall proto era. ShelleyBasedEra era
=> SL.ProtVer
-> SL.ShelleyGenesis (EraCrypto era)
-> [SL.VKey 'SL.BlockIssuer (EraCrypto era)]
-> BlockConfig (ShelleyBlock proto era)
mkShelleyBlockConfig protVer genesis blockIssuerVKeys = ShelleyConfig {
shelleyProtocolVersion = protVer
, shelleySystemStart = SystemStart $ SL.sgSystemStart genesis
, shelleyNetworkMagic = NetworkMagic $ SL.sgNetworkMagic genesis
, shelleyBlockIssuerVKeys = Map.fromList
[ (SL.hashKey k, k)
| k <- blockIssuerVKeys
]
, shelleyVRFTiebreakerFlavor
}
where
shelleyVRFTiebreakerFlavor
| isBeforeConway (Proxy @era)
= UnrestrictedVRFTiebreaker
| otherwise
-- See 'RestrictedVRFTiebreaker' for context. 5 slots is the "usual" value
-- we consider when talking about the maximum propagation delay.
--
-- TODO derive/clamp this value from something else, eg active slot
-- coefficient?
= RestrictedVRFTiebreaker 5
{-------------------------------------------------------------------------------
Codec config
-------------------------------------------------------------------------------}
-- | No particular codec configuration is needed for Shelley
data instance CodecConfig (ShelleyBlock proto era) = ShelleyCodecConfig
deriving (Generic, NoThunks)
{-------------------------------------------------------------------------------
Storage config
-------------------------------------------------------------------------------}
data instance StorageConfig (ShelleyBlock proto era) = ShelleyStorageConfig {
-- | Needed for 'nodeCheckIntegrity'
shelleyStorageConfigSlotsPerKESPeriod :: !Word64
-- | Needed for 'nodeImmutableDbChunkInfo'
, shelleyStorageConfigSecurityParam :: !SecurityParam
}
deriving (Generic, NoThunks)
{-------------------------------------------------------------------------------
Compact genesis
-------------------------------------------------------------------------------}
-- | Compact variant of 'SL.ShelleyGenesis' with some fields erased that are
-- only used on start-up and that should not be kept in memory forever.
--
-- Concretely:
--
-- * The 'sgInitialFunds' field is erased. It is only used to set up the initial
-- UTxO in tests and testnets.
--
-- * The 'sgStaking' field is erased. It is only used to register initial stake
-- pools in tests and benchmarks.
newtype CompactGenesis c = CompactGenesis {
getCompactGenesis :: SL.ShelleyGenesis c
}
deriving stock (Eq, Show, Generic)
deriving newtype (ToCBOR, FromCBOR)
deriving anyclass instance Crypto c => NoThunks (CompactGenesis c)
-- | Compacts the given 'SL.ShelleyGenesis'.
compactGenesis :: SL.ShelleyGenesis c -> CompactGenesis c
compactGenesis genesis = CompactGenesis $
genesis {
SL.sgInitialFunds = mempty
, SL.sgStaking = SL.emptyGenesisStaking
}