Source file level_repr.ml
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
type t = {
level : Raw_level_repr.t;
level_position : int32;
cycle : Cycle_repr.t;
cycle_position : int32;
expected_commitment : bool;
}
include Compare.Make (struct
type nonrec t = t
let compare {level = l1; _} {level = l2; _} = Raw_level_repr.compare l1 l2
end)
type level = t
let pp ppf {level; _} = Raw_level_repr.pp ppf level
let pp_full ppf l =
Format.fprintf
ppf
"%a.%ld (cycle %a.%ld)"
Raw_level_repr.pp
l.level
l.level_position
Cycle_repr.pp
l.cycle
l.cycle_position
let encoding =
let open Data_encoding in
conv
(fun {level; level_position; cycle; cycle_position; expected_commitment} ->
(level, level_position, cycle, cycle_position, expected_commitment))
(fun (level, level_position, cycle, cycle_position, expected_commitment) ->
{level; level_position; cycle; cycle_position; expected_commitment})
(obj5
(req
"level"
~description:
"The level of the block relative to genesis. This is also the \
Shell's notion of level."
Raw_level_repr.encoding)
(req
"level_position"
~description:
"The level of the block relative to the successor of the genesis \
block. More precisely, it is the position of the block relative \
to the block that starts the \"Alpha family\" of protocols, which \
includes all protocols except Genesis (that is, from 001 \
onwards)."
int32)
(req
"cycle"
~description:
"The current cycle's number. Note that cycles are a \
protocol-specific notion. As a result, the cycle number starts at \
0 with the first block of the Alpha family of protocols."
Cycle_repr.encoding)
(req
"cycle_position"
~description:
"The current level of the block relative to the first block of the \
current cycle."
int32)
(req
"expected_commitment"
~description:
"Tells whether the baker of this block has to commit a seed nonce \
hash."
bool))
let diff {level = l1; _} {level = l2; _} =
Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2)
type cycle_era = {
first_level : Raw_level_repr.t;
first_cycle : Cycle_repr.t;
blocks_per_cycle : int32;
blocks_per_commitment : int32;
}
type cycle_eras = cycle_era list
type error += Invalid_cycle_eras
let () =
register_error_kind
`Temporary
~id:"level_repr.invalid_cycle_eras"
~title:"Invalid cycle eras"
~description:
"The cycles eras are not valid: empty list or non-decreasing first \
levels or first cycles."
~pp:(fun ppf () ->
Format.fprintf
ppf
"The cycles eras are not valid: empty list or non-decreasing first \
levels or first cycles.")
Data_encoding.empty
(function Invalid_cycle_eras -> Some () | _ -> None)
(fun () -> Invalid_cycle_eras)
let create_cycle_eras cycle_eras =
let open Result_syntax in
match cycle_eras with
| [] -> tzfail Invalid_cycle_eras
| newest_era :: older_eras ->
let rec aux {first_level; first_cycle; _} older_eras =
match older_eras with
| ({
first_level = first_level_of_previous_era;
first_cycle = first_cycle_of_previous_era;
_;
} as previous_era)
:: even_older_eras ->
if
Raw_level_repr.(first_level > first_level_of_previous_era)
&& Cycle_repr.(first_cycle > first_cycle_of_previous_era)
then aux previous_era even_older_eras
else tzfail Invalid_cycle_eras
| [] -> return_unit
in
let* () = aux newest_era older_eras in
return cycle_eras
let add_cycle_era new_era cycle_eras = create_cycle_eras (new_era :: cycle_eras)
let cycle_era_encoding =
let open Data_encoding in
conv
(fun {first_level; first_cycle; blocks_per_cycle; blocks_per_commitment} ->
(first_level, first_cycle, blocks_per_cycle, blocks_per_commitment))
(fun (first_level, first_cycle, blocks_per_cycle, blocks_per_commitment) ->
{first_level; first_cycle; blocks_per_cycle; blocks_per_commitment})
(obj4
(req
"first_level"
~description:"The first level of a new cycle era."
Raw_level_repr.encoding)
(req
"first_cycle"
~description:"The first cycle of a new cycle era."
Cycle_repr.encoding)
(req
"blocks_per_cycle"
~description:
"The value of the blocks_per_cycle constant used during the cycle \
era starting with first_level."
int32)
(req
"blocks_per_commitment"
~description:
"The value of the blocks_per_commitment constant used during the \
cycle era starting with first_level."
int32))
let cycle_eras_encoding =
Data_encoding.conv_with_guard
(fun eras -> eras)
(fun eras ->
match create_cycle_eras eras with
| Ok eras -> Ok eras
| Error _ -> Error "Invalid cycle eras")
(Data_encoding.list cycle_era_encoding)
let current_era = function [] -> assert false | cycle_era :: _ -> cycle_era
let root_level cycle_eras =
let first_era = List.last_opt cycle_eras in
let first_era =
match first_era with
| Some first_era -> first_era
| None ->
assert false
in
{
level = first_era.first_level;
level_position = 0l;
cycle = Cycle_repr.root;
cycle_position = 0l;
expected_commitment = false;
}
let era_of_level ~cycle_eras level =
let rec aux = function
| ({first_level; _} as era) :: previous_eras ->
if Raw_level_repr.(level >= first_level) then era else aux previous_eras
| [] -> assert false
in
aux cycle_eras
let era_of_cycle ~cycle_eras cycle =
let rec aux = function
| ({first_cycle; _} as era) :: previous_eras ->
if Cycle_repr.(cycle >= first_cycle) then era else aux previous_eras
| [] -> assert false
in
aux cycle_eras
let cycle_from_raw_with_era era level =
let {first_level; first_cycle; blocks_per_cycle; _} = era in
let level_position_in_era = Raw_level_repr.diff level first_level in
assert (Compare.Int32.(level_position_in_era >= 0l)) ;
let cycles_since_era_start =
Int32.div level_position_in_era blocks_per_cycle
in
let cycle =
Cycle_repr.add first_cycle (Int32.to_int cycles_since_era_start)
in
(cycle, level_position_in_era)
let level_from_raw_with_era era ~first_level_in_alpha_family level =
let cycle, level_position_in_era = cycle_from_raw_with_era era level in
let cycle_position = Int32.rem level_position_in_era era.blocks_per_cycle in
let level_position = Raw_level_repr.diff level first_level_in_alpha_family in
let expected_commitment =
Compare.Int32.(
Int32.rem cycle_position era.blocks_per_commitment
= Int32.pred era.blocks_per_commitment)
in
{level; level_position; cycle; cycle_position; expected_commitment}
let cycle_from_raw ~cycle_eras l =
let era = era_of_level ~cycle_eras l in
fst @@ cycle_from_raw_with_era era l
let level_from_raw_aux_exn ~cycle_eras level =
let first_level_in_alpha_family =
match List.rev cycle_eras with
| [] -> assert false
| {first_level; _} :: _ -> first_level
in
let era = era_of_level ~cycle_eras level in
level_from_raw_with_era era ~first_level_in_alpha_family level
let level_from_raw ~cycle_eras l = level_from_raw_aux_exn ~cycle_eras l
type error += Level_not_in_alpha of Raw_level_repr.t
let () =
register_error_kind
`Permanent
~id:"level_not_in_alpha"
~title:"Level not in Alpha family"
~description:"Level not in Alpha family"
~pp:(fun ppf level ->
Format.fprintf
ppf
"Level %a is not in the Alpha family of protocols."
Raw_level_repr.pp
level)
Data_encoding.(obj1 (req "level" Raw_level_repr.encoding))
(function Level_not_in_alpha level -> Some level | _ -> None)
(fun level -> Level_not_in_alpha level)
let level_from_raw_aux ~cycle_eras level =
let open Result_syntax in
let first_level_in_alpha_family =
match List.rev cycle_eras with
| [] -> assert false
| {first_level; _} :: _ -> first_level
in
let+ () =
error_when
Raw_level_repr.(level < first_level_in_alpha_family)
(Level_not_in_alpha level)
in
let era = era_of_level ~cycle_eras level in
level_from_raw_with_era era ~first_level_in_alpha_family level
type error += Negative_level_and_offset_sum of int32 * int32
let () =
register_error_kind
`Permanent
~id:"negative_level_and_offset_sum"
~title:"Negative sum of level and offset"
~description:"Negative sum of level and offset"
~pp:(fun ppf (level, offset) ->
Format.fprintf
ppf
"Sum of level (%ld) and offset (%ld) is negative."
level
offset)
Data_encoding.(obj2 (req "level" int32) (req "offset" int32))
(function
| Negative_level_and_offset_sum (level, offset) -> Some (level, offset)
| _ -> None)
(fun (level, offset) -> Negative_level_and_offset_sum (level, offset))
let level_from_raw_with_offset ~cycle_eras ~offset raw_level =
let res = Raw_level_repr.(of_int32 (Int32.add (to_int32 raw_level) offset)) in
match res with
| Ok level -> level_from_raw_aux ~cycle_eras level
| Error _ ->
Result_syntax.tzfail
(Negative_level_and_offset_sum
(Raw_level_repr.to_int32 raw_level, offset))
let first_level_in_cycle_from_eras ~cycle_eras cycle =
let first_level_in_alpha_family =
match List.rev cycle_eras with
| [] -> assert false
| {first_level; _} :: _ -> first_level
in
let era = era_of_cycle ~cycle_eras cycle in
let cycle_position = Cycle_repr.diff cycle era.first_cycle in
let offset = Int32.mul era.blocks_per_cycle cycle_position in
let first_level_in_cycle =
Raw_level_repr.(of_int32_exn (Int32.add (to_int32 era.first_level) offset))
in
level_from_raw_with_era era ~first_level_in_alpha_family first_level_in_cycle
let last_of_cycle ~cycle_eras level =
let era = era_of_level ~cycle_eras level.level in
Compare.Int32.(Int32.succ level.cycle_position = era.blocks_per_cycle)
module Internal_for_tests = struct
let add_level level n =
let raw_level = level.level in
let new_raw_level = Raw_level_repr.add raw_level n in
{level with level = new_raw_level}
let add_cycles ~blocks_per_cycle level n =
{
level with
cycle = Cycle_repr.add level.cycle n;
level = Raw_level_repr.add level.level (n * blocks_per_cycle);
level_position =
Int32.add level.level_position (Int32.of_int (n * blocks_per_cycle));
}
let root =
{
level = Raw_level_repr.root;
level_position = 0l;
cycle = Cycle_repr.root;
cycle_position = 0l;
expected_commitment = false;
}
end