package tezos-protocol-013-PtJakart

  1. Overview
  2. Docs
package tezos-protocol-013-PtJakart
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

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
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

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 =
  match cycle_eras with
  | [] -> error 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 error Invalid_cycle_eras
        | [] -> ok ()
      in
      aux newest_era older_eras >>? fun () -> ok 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 ->
        (* {!create_cycle_eras} fails if the list is empty.
           {!cycle_eras_encoding} uses {!create_cycle_eras} and so fails on empty
           lists too. *)
        assert false
  in
  {
    level = first_era.first_level;
    level_position = 0l;
    cycle = Cycle_repr.root;
    cycle_position = 0l;
    expected_commitment = false;
  }

(* This function returns the cycle era to which [level] belongs. *)
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

(* This function returns the cycle era to which [cycle] belongs. *)
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

(* precondition: [level] belongs to [era] *)
let level_from_raw_with_era era ~first_level_in_alpha_family level =
  let {first_level; first_cycle; blocks_per_cycle; blocks_per_commitment} =
    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
  let cycle_position = Int32.rem level_position_in_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 blocks_per_commitment
      = Int32.pred blocks_per_commitment)
  in
  {level; level_position; cycle; cycle_position; expected_commitment}

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 first_level_in_alpha_family =
    match List.rev cycle_eras with
    | [] -> assert false
    | {first_level; _} :: _ -> first_level
  in
  error_when
    Raw_level_repr.(level < first_level_in_alpha_family)
    (Level_not_in_alpha level)
  >|? fun () ->
  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 _ ->
      error
        (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}
end