-
Notifications
You must be signed in to change notification settings - Fork 20
/
Protocol.hs
375 lines (333 loc) · 14.2 KB
/
Protocol.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
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.HardFork.Combinator.Protocol (
HardForkSelectView (..)
-- * Re-exports to keep 'Protocol.State' an internal module
, HardForkCanBeLeader
, HardForkChainDepState
, HardForkIsLeader
, HardForkValidationErr (..)
-- * Re-exports to keep 'Protocol.LedgerView' an internal module
, HardForkLedgerView
, HardForkLedgerView_ (..)
-- * Type family instances
, Ticked (..)
) where
import Control.Monad.Except
import Data.Functor.Product
import Data.SOP.BasicFunctors
import Data.SOP.Index
import Data.SOP.InPairs (InPairs (..))
import qualified Data.SOP.InPairs as InPairs
import qualified Data.SOP.Match as Match
import qualified Data.SOP.OptNP as OptNP
import Data.SOP.Strict
import GHC.Generics (Generic)
import GHC.Stack
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.HardFork.Combinator.Abstract
import Ouroboros.Consensus.HardFork.Combinator.AcrossEras
import Ouroboros.Consensus.HardFork.Combinator.Basics
import Ouroboros.Consensus.HardFork.Combinator.Block
import Ouroboros.Consensus.HardFork.Combinator.Info
import Ouroboros.Consensus.HardFork.Combinator.PartialConfig
import Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel
import Ouroboros.Consensus.HardFork.Combinator.Protocol.LedgerView
(HardForkLedgerView, HardForkLedgerView_ (..))
import Ouroboros.Consensus.HardFork.Combinator.State (HardForkState,
Translate (..))
import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
import Ouroboros.Consensus.HardFork.Combinator.Translation
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.TypeFamilyWrappers
import Ouroboros.Consensus.Util ((.:))
{-------------------------------------------------------------------------------
ChainSelection
-------------------------------------------------------------------------------}
newtype HardForkSelectView xs = HardForkSelectView {
getHardForkSelectView :: WithBlockNo OneEraSelectView xs
}
deriving (Show, Eq)
deriving newtype (NoThunks)
instance CanHardFork xs => ChainOrder (HardForkSelectView xs) where
compareChains (HardForkSelectView l) (HardForkSelectView r) =
acrossEraSelection
hardForkChainSel
(mapWithBlockNo getOneEraSelectView l)
(mapWithBlockNo getOneEraSelectView r)
mkHardForkSelectView ::
BlockNo
-> NS WrapSelectView xs
-> HardForkSelectView xs
mkHardForkSelectView bno view =
HardForkSelectView $ WithBlockNo bno (OneEraSelectView view)
{-------------------------------------------------------------------------------
ConsensusProtocol
-------------------------------------------------------------------------------}
type HardForkChainDepState xs = HardForkState WrapChainDepState xs
instance CanHardFork xs => ConsensusProtocol (HardForkProtocol xs) where
type ChainDepState (HardForkProtocol xs) = HardForkChainDepState xs
type ValidationErr (HardForkProtocol xs) = HardForkValidationErr xs
type SelectView (HardForkProtocol xs) = HardForkSelectView xs
type LedgerView (HardForkProtocol xs) = HardForkLedgerView xs
type CanBeLeader (HardForkProtocol xs) = HardForkCanBeLeader xs
type IsLeader (HardForkProtocol xs) = HardForkIsLeader xs
type ValidateView (HardForkProtocol xs) = OneEraValidateView xs
-- Operations on the state
tickChainDepState = tick
checkIsLeader = check
updateChainDepState = update
reupdateChainDepState = reupdate
--
-- Straight-forward extensions
--
-- Security parameter must be equal across /all/ eras
protocolSecurityParam = hardForkConsensusConfigK
{-------------------------------------------------------------------------------
BlockSupportsProtocol
-------------------------------------------------------------------------------}
instance CanHardFork xs => BlockSupportsProtocol (HardForkBlock xs) where
validateView HardForkBlockConfig{..} =
OneEraValidateView
. hczipWith proxySingle (WrapValidateView .: validateView) cfgs
. getOneEraHeader
. getHardForkHeader
where
cfgs = getPerEraBlockConfig hardForkBlockConfigPerEra
selectView HardForkBlockConfig{..} hdr =
mkHardForkSelectView (blockNo hdr)
. hczipWith proxySingle (WrapSelectView .: selectView) cfgs
. getOneEraHeader
$ getHardForkHeader hdr
where
cfgs = getPerEraBlockConfig hardForkBlockConfigPerEra
{-------------------------------------------------------------------------------
Ticking the chain dependent state
-------------------------------------------------------------------------------}
data instance Ticked (HardForkChainDepState xs) =
TickedHardForkChainDepState {
tickedHardForkChainDepStatePerEra ::
HardForkState (Ticked :.: WrapChainDepState) xs
-- | 'EpochInfo' constructed from the 'LedgerView'
, tickedHardForkChainDepStateEpochInfo ::
EpochInfo (Except PastHorizonException)
}
tick :: CanHardFork xs
=> ConsensusConfig (HardForkProtocol xs)
-> HardForkLedgerView xs
-> SlotNo
-> HardForkChainDepState xs
-> Ticked (HardForkChainDepState xs)
tick cfg@HardForkConsensusConfig{..}
(HardForkLedgerView transition ledgerView)
slot
chainDepState = TickedHardForkChainDepState {
tickedHardForkChainDepStateEpochInfo = ei
, tickedHardForkChainDepStatePerEra =
State.align
(translateConsensus ei cfg)
(hcmap proxySingle (fn_2 . tickOne) cfgs)
ledgerView
chainDepState
}
where
cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra
ei = State.epochInfoPrecomputedTransitionInfo
hardForkConsensusConfigShape
transition
ledgerView
tickOne :: SingleEraBlock blk
=> WrapPartialConsensusConfig blk
-> WrapLedgerView blk
-> WrapChainDepState blk
-> (Ticked :.: WrapChainDepState) blk
tickOne cfg' ledgerView' chainDepState' = Comp $
WrapTickedChainDepState $
tickChainDepState
(completeConsensusConfig' ei cfg')
(unwrapLedgerView ledgerView')
slot
(unwrapChainDepState chainDepState')
{-------------------------------------------------------------------------------
Leader check
NOTE: The precondition to 'align' is satisfied: the consensus state will never
be ahead (but possibly behind) the ledger state, which we tick first.
-------------------------------------------------------------------------------}
-- | We are a leader if we have a proof from one of the eras
type HardForkIsLeader xs = OneEraIsLeader xs
-- | We have one or more 'BlockForging's, and thus 'CanBeLeader' proofs, for
-- each era in which we can forge blocks.
type HardForkCanBeLeader xs = SomeErasCanBeLeader xs
-- | POSTCONDITION: if the result is @Just isLeader@, then 'HardForkCanBeLeader'
-- and the ticked 'ChainDepState' must be in the same era. The returned
-- @isLeader@ will be from the same era.
check :: forall xs. (CanHardFork xs, HasCallStack)
=> ConsensusConfig (HardForkProtocol xs)
-> HardForkCanBeLeader xs
-> SlotNo
-> Ticked (ChainDepState (HardForkProtocol xs))
-> Maybe (HardForkIsLeader xs)
check HardForkConsensusConfig{..}
(SomeErasCanBeLeader canBeLeader)
slot
(TickedHardForkChainDepState chainDepState ei) =
undistrib $
hczipWith3
proxySingle
checkOne
cfgs
(OptNP.toNP canBeLeader)
(State.tip chainDepState)
where
cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra
checkOne ::
SingleEraBlock blk
=> WrapPartialConsensusConfig blk
-> (Maybe :.: WrapCanBeLeader) blk
-> (Ticked :.: WrapChainDepState) blk
-> (Maybe :.: WrapIsLeader) blk
checkOne cfg' (Comp mCanBeLeader) (Comp chainDepState') = Comp $ do
canBeLeader' <- mCanBeLeader
WrapIsLeader <$>
checkIsLeader
(completeConsensusConfig' ei cfg')
(unwrapCanBeLeader canBeLeader')
slot
(unwrapTickedChainDepState chainDepState')
undistrib :: NS (Maybe :.: WrapIsLeader) xs -> Maybe (HardForkIsLeader xs)
undistrib = hcollapse . himap inj
where
inj :: Index xs blk
-> (Maybe :.: WrapIsLeader) blk
-> K (Maybe (HardForkIsLeader xs)) blk
inj index (Comp mIsLeader) = K $
OneEraIsLeader . injectNS index <$> mIsLeader
{-------------------------------------------------------------------------------
Rolling forward and backward
-------------------------------------------------------------------------------}
data HardForkValidationErr xs =
-- | Validation error from one of the eras
HardForkValidationErrFromEra (OneEraValidationErr xs)
-- | We tried to apply a block from the wrong era
| HardForkValidationErrWrongEra (MismatchEraInfo xs)
deriving (Generic)
update :: forall xs. CanHardFork xs
=> ConsensusConfig (HardForkProtocol xs)
-> OneEraValidateView xs
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> Except (HardForkValidationErr xs) (HardForkChainDepState xs)
update HardForkConsensusConfig{..}
(OneEraValidateView view)
slot
(TickedHardForkChainDepState chainDepState ei) =
case State.match view chainDepState of
Left mismatch ->
throwError $ HardForkValidationErrWrongEra . MismatchEraInfo $
Match.bihcmap
proxySingle
singleEraInfo
(LedgerEraInfo . chainDepStateInfo . State.currentState)
mismatch
Right matched ->
hsequence'
. hcizipWith proxySingle (updateEra ei slot) cfgs
$ matched
where
cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra
updateEra :: forall xs blk. SingleEraBlock blk
=> EpochInfo (Except PastHorizonException)
-> SlotNo
-> Index xs blk
-> WrapPartialConsensusConfig blk
-> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
-> (Except (HardForkValidationErr xs) :.: WrapChainDepState) blk
updateEra ei slot index cfg
(Pair view (Comp chainDepState)) = Comp $
withExcept (injectValidationErr index) $
fmap WrapChainDepState $
updateChainDepState
(completeConsensusConfig' ei cfg)
(unwrapValidateView view)
slot
(unwrapTickedChainDepState chainDepState)
reupdate :: forall xs. CanHardFork xs
=> ConsensusConfig (HardForkProtocol xs)
-> OneEraValidateView xs
-> SlotNo
-> Ticked (HardForkChainDepState xs)
-> HardForkChainDepState xs
reupdate HardForkConsensusConfig{..}
(OneEraValidateView view)
slot
(TickedHardForkChainDepState chainDepState ei) =
case State.match view chainDepState of
Left mismatch ->
error $ show . HardForkValidationErrWrongEra . MismatchEraInfo $
Match.bihcmap
proxySingle
singleEraInfo
(LedgerEraInfo . chainDepStateInfo . State.currentState)
mismatch
Right matched ->
hczipWith proxySingle (reupdateEra ei slot) cfgs
$ matched
where
cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra
reupdateEra :: SingleEraBlock blk
=> EpochInfo (Except PastHorizonException)
-> SlotNo
-> WrapPartialConsensusConfig blk
-> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
-> WrapChainDepState blk
reupdateEra ei slot cfg (Pair view (Comp chainDepState)) =
WrapChainDepState $
reupdateChainDepState
(completeConsensusConfig' ei cfg)
(unwrapValidateView view)
slot
(unwrapTickedChainDepState chainDepState)
{-------------------------------------------------------------------------------
Auxiliary
-------------------------------------------------------------------------------}
chainDepStateInfo :: forall blk. SingleEraBlock blk
=> (Ticked :.: WrapChainDepState) blk -> SingleEraInfo blk
chainDepStateInfo _ = singleEraInfo (Proxy @blk)
translateConsensus :: forall xs. CanHardFork xs
=> EpochInfo (Except PastHorizonException)
-> ConsensusConfig (HardForkProtocol xs)
-> InPairs (Translate WrapChainDepState) xs
translateConsensus ei HardForkConsensusConfig{..} =
InPairs.requiringBoth cfgs $
translateChainDepState hardForkEraTranslation
where
pcfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra
cfgs = hcmap proxySingle (completeConsensusConfig'' ei) pcfgs
injectValidationErr :: Index xs blk
-> ValidationErr (BlockProtocol blk)
-> HardForkValidationErr xs
injectValidationErr index =
HardForkValidationErrFromEra
. OneEraValidationErr
. injectNS index
. WrapValidationErr
{-------------------------------------------------------------------------------
Instances
-------------------------------------------------------------------------------}
deriving instance CanHardFork xs => Eq (HardForkValidationErr xs)
deriving instance CanHardFork xs => Show (HardForkValidationErr xs)
deriving instance CanHardFork xs => NoThunks (HardForkValidationErr xs)