Source file `sc_rollup_stake_storage.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
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com>                *)
(* Copyright (c) 2022 TriliTech <contact@trili.tech>                         *)
(*                                                                           *)
(* 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.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Sc_rollup_errors
module Store = Storage.Sc_rollup
module Commitment_storage = Sc_rollup_commitment_storage
module Commitment = Sc_rollup_commitment_repr
module Commitment_hash = Commitment.Hash

(** As the sets encoded with a list are proportional to the number of
    stakers on the rollup, we admit that it will be a small set. We
    also admit that a small list respecting the set properties is more
    efficient than using a real {!Set.S}. *)
module Set_out_of_list (S : sig
  type t := Raw_context.t * Sc_rollup_repr.t

  type key

  type value

  val equal_value : value -> value -> bool

  val find : t -> key -> (Raw_context.t * value list option) tzresult Lwt.t

  val add :
    t -> key -> value list -> (Raw_context.t * int * bool) tzresult Lwt.t

  val remove : t -> key -> (Raw_context.t * int) tzresult Lwt.t
end) =
struct
  let find ctxt rollup key = S.find (ctxt, rollup) key

  let get ctxt rollup key =
    let open Lwt_result_syntax in
    let* ctxt, values_opt = find ctxt rollup key in
    return (ctxt, Option.value ~default:[] values_opt)

  let remove ctxt rollup key = S.remove (ctxt, rollup) key

  let mem ctxt rollup key value =
    let open Lwt_result_syntax in
    let* ctxt, values = get ctxt rollup key in
    let exists = List.mem ~equal:S.equal_value value values in
    return (ctxt, exists)

  let add ctxt rollup key value =
    let open Lwt_result_syntax in
    let* ctxt, existing_values = get ctxt rollup key in
    let exists = List.mem ~equal:S.equal_value value existing_values in
    if exists then return (ctxt, 0, existing_values)
    else
      let values = value :: existing_values in
      let* ctxt, diff_size, _existed = S.add (ctxt, rollup) key values in
      return (ctxt, diff_size, values)
end

module Commitments_per_inbox_level = Set_out_of_list (struct
  type key = Raw_level_repr.t

  type value = Commitment_hash.t

  let equal_value = Commitment_hash.equal

  let find = Store.Commitments_per_inbox_level.find

  let add = Store.Commitments_per_inbox_level.add

  let remove = Store.Commitments_per_inbox_level.remove_existing
end)

module Commitment_stakers = Set_out_of_list (struct
  type key = Commitment_hash.t

  type value = Sc_rollup_staker_index_repr.t

  let equal_value = Sc_rollup_staker_index_repr.equal

  let find = Store.Commitment_stakers.find

  let add = Store.Commitment_stakers.add

  let remove = Store.Commitment_stakers.remove_existing
end)

(* Looks for the commitment [staker] is staking on, in the list of commitments
   posted for this level. *)
let rec find_commitment_of_staker_in_commitments ctxt rollup staker_index =
  let open Lwt_result_syntax in
  function
  | [] -> return (ctxt, None)
  | commitment_hash :: rst ->
      let* ctxt, exists =
        Commitment_stakers.mem ctxt rollup commitment_hash staker_index
      in
      if exists then return (ctxt, Some commitment_hash)
      else find_commitment_of_staker_in_commitments ctxt rollup staker_index rst

let get_commitment_of_staker_in_commitments ctxt rollup staker_index commitments
    =
  let open Lwt_result_syntax in
  let* ctxt, opt =
    find_commitment_of_staker_in_commitments
      ctxt
      rollup
      staker_index
      commitments
  in
  match opt with
  | Some res -> return (ctxt, res)
  | None -> tzfail Sc_rollup_not_staked

let find_staker ctxt rollup staker =
  let open Lwt_result_syntax in
  let* ctxt, staker_index =
    Sc_rollup_staker_index_storage.get_staker_index_unsafe ctxt rollup staker
  in
  let* ctxt, level = Store.Stakers.get (ctxt, rollup) staker_index in
  let* ctxt, commitments_opt =
    Commitments_per_inbox_level.find ctxt rollup level
  in
  match commitments_opt with
  | None ->
      (* The staked commitment is no longer active (i.e. cemented). *)
      return (ctxt, None)
  | Some commitments ->
      let+ ctxt, commitment_hash =
        get_commitment_of_staker_in_commitments
          ctxt
          rollup
          staker_index
          commitments
      in
      (ctxt, Some commitment_hash)

let commitments_uncarbonated ctxt ~rollup ~inbox_level =
  let open Lwt_result_syntax in
  let* _, commitments =
    Commitments_per_inbox_level.find ctxt rollup inbox_level
  in
  return commitments

let stakers_ids_uncarbonated ctxt ~rollup ~commitment =
  let open Lwt_result_syntax in
  let* _, stakers_ids =
    Store.Commitment_stakers.get (ctxt, rollup) commitment
  in
  return stakers_ids

let staker_id_uncarbonated ctxt ~rollup ~pkh =
  let open Lwt_result_syntax in
  let* _, staker_index = Store.Staker_index.get (ctxt, rollup) pkh in
  return staker_index

let stakers_pkhs_uncarbonated ctxt ~rollup =
  Sc_rollup_staker_index_storage.list_stakers_uncarbonated ctxt rollup

let get_contract_and_stake ctxt staker =
  let staker_contract = Contract_repr.Implicit staker in
  let stake = Constants_storage.sc_rollup_stake_amount ctxt in
  (staker_contract, stake)

(** [assert_staked_on_lcc_or_ancestor ctxt rollup ~staker_index lcc_inbox_level]
    fails unless the most recent commitment [staker_index] has staked
    is older than [lcc_inbox_level]. This is a necessary condition to
    withdraw a staker's bond. *)
let assert_staked_on_lcc_or_ancestor ctxt rollup ~staker_index lcc_inbox_level =
  let open Lwt_result_syntax in
  let* ctxt, last_staked_level =
    Store.Stakers.get (ctxt, rollup) staker_index
  in
  let* () =
    fail_unless
      Raw_level_repr.(last_staked_level <= lcc_inbox_level)
      Sc_rollup_not_staked_on_lcc_or_ancestor
  in
  return ctxt

let deposit_stake ctxt rollup staker =
  let open Lwt_result_syntax in
  (* Freeze the stake of [staker]. *)
  let staker_contract, stake = get_contract_and_stake ctxt staker in
  let* ctxt, staker_balance =
    Contract_storage.get_balance_carbonated ctxt staker_contract
  in
  let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in
  let* ctxt, balance_updates =
    trace
      (Sc_rollup_staker_funds_too_low
         {
           staker;
           sc_rollup = rollup;
           staker_balance;
           min_expected_balance = stake;
         })
    @@ Token.transfer
         ctxt
         (`Contract staker_contract)
         (`Frozen_bonds (staker_contract, bond_id))
         stake
  in
  (* Initialize the index of [staker]. *)
  let* ctxt, staker_index =
    Sc_rollup_staker_index_storage.fresh_staker_index ctxt rollup staker
  in
  return (ctxt, balance_updates, staker_index)

let withdraw_stake ctxt rollup staker =
  let open Lwt_result_syntax in
  let* _lcc, lcc_inbox_level, ctxt =
    Commitment_storage.last_cemented_commitment_hash_with_level ctxt rollup
  in
  let* ctxt, staker_index =
    Sc_rollup_staker_index_storage.get_staker_index_unsafe ctxt rollup staker
  in
  let* ctxt =
    assert_staked_on_lcc_or_ancestor ctxt rollup ~staker_index lcc_inbox_level
  in
  let staker_contract, stake = get_contract_and_stake ctxt staker in
  let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in
  let* ctxt, balance_updates =
    Token.transfer
      ctxt
      (`Frozen_bonds (staker_contract, bond_id))
      (`Contract staker_contract)
      stake
  in
  let* ctxt = Sc_rollup_staker_index_storage.remove_staker ctxt rollup staker in
  return (ctxt, balance_updates)

let assert_commitment_not_too_far_ahead ctxt rollup lcc commitment =
  let open Lwt_result_syntax in
  let* lcc, ctxt = Commitment_storage.get_commitment_unsafe ctxt rollup lcc in
  let min_level = Commitment.(lcc.inbox_level) in
  let max_level = Commitment.(commitment.inbox_level) in
  let sc_rollup_max_lookahead =
    Constants_storage.sc_rollup_max_lookahead_in_blocks ctxt
  in
  let* () =
    fail_when
      Compare.Int32.(
        sc_rollup_max_lookahead < Raw_level_repr.diff max_level min_level)
      Sc_rollup_too_far_ahead
  in
  return ctxt

(** Enfore that a commitment's inbox level increases by an exact fixed
    amount over its predecessor.  This property is used in several
    places - not obeying it causes severe breakage. *)
let assert_commitment_period ctxt rollup commitment =
  let open Lwt_result_syntax in
  let pred_hash = Commitment.(commitment.predecessor) in
  let* pred, ctxt =
    Commitment_storage.get_commitment_unsafe ctxt rollup pred_hash
  in
  let pred_level = Commitment.(pred.inbox_level) in
  (* Commitments needs to be posted for inbox levels every [commitment_period].
     Therefore, [commitment.inbox_level] must be
     [predecessor_commitment.inbox_level + commitment_period]. *)
  let sc_rollup_commitment_period =
    Constants_storage.sc_rollup_commitment_period_in_blocks ctxt
  in
  let* () =
    fail_unless
      Raw_level_repr.(
        commitment.inbox_level = add pred_level sc_rollup_commitment_period)
      Sc_rollup_bad_inbox_level
  in
  return ctxt

(** [assert_commitment_is_not_past_curfew ctxt rollup inbox_level]
    will look in the storage [Commitment_first_publication_level] for
    the level of the oldest commit for [inbox_level] and if it is more
    than [sc_rollup_challenge_window_in_blocks] ago it fails with
    [Sc_rollup_commitment_past_curfew]. Otherwise it adds the
    respective storage (if it is not set) and returns the context. *)
let assert_commitment_is_not_past_curfew ctxt rollup inbox_level =
  let open Lwt_result_syntax in
  let current_level = (Raw_context.current_level ctxt).level in
  let* ctxt, oldest_commit =
    Store.Commitment_first_publication_level.find (ctxt, rollup) inbox_level
  in
  match oldest_commit with
  | Some oldest_commit ->
      let refutation_deadline_blocks =
        Int32.of_int
        @@ Constants_storage.sc_rollup_challenge_window_in_blocks ctxt
      in
      let+ () =
        fail_when
          Compare.Int32.(
            Raw_level_repr.diff current_level oldest_commit
            > refutation_deadline_blocks)
          Sc_rollup_commitment_past_curfew
      in
      (ctxt, 0)
  | None ->
      (* The storage cost is covered by the stake. *)
      let* ctxt, size_diff, _existed =
        Store.Commitment_first_publication_level.add
          (ctxt, rollup)
          inbox_level
          current_level
      in
      return (ctxt, size_diff)

(** Check invariants on [inbox_level], enforcing overallocation of storage,
    regularity of block production and curfew.

    The constants used by [assert_refine_conditions_met] must be chosen such
    that the maximum cost of storage allocated by each staker is at most the size
    of their deposit.
 *)
let assert_refine_conditions_met ~current_level ~lcc_inbox_level ctxt rollup lcc
    commitment =
  let open Lwt_result_syntax in
  let commitment_inbox_level = commitment.Commitment.inbox_level in
  let* () =
    fail_unless
      Raw_level_repr.(commitment_inbox_level > lcc_inbox_level)
      (Sc_rollup_commitment_too_old
         {last_cemented_inbox_level = lcc_inbox_level; commitment_inbox_level})
  in
  let* ctxt = assert_commitment_not_too_far_ahead ctxt rollup lcc commitment in
  let* ctxt = assert_commitment_period ctxt rollup commitment in
  let* ctxt, size_diff =
    assert_commitment_is_not_past_curfew
      ctxt
      rollup
      Commitment.(commitment.inbox_level)
  in
  let* () =
    fail_unless
      Raw_level_repr.(commitment_inbox_level < current_level)
      (Sc_rollup_commitment_from_future
         {current_level; inbox_level = commitment.inbox_level})
  in
  return (ctxt, size_diff)

let is_staked_on ctxt rollup staker commitment_hash =
  let open Lwt_result_syntax in
  let* ctxt, staker_index_opt =
    Sc_rollup_staker_index_storage.find_staker_index_unsafe ctxt rollup staker
  in
  match staker_index_opt with
  | None -> return (ctxt, false)
  | Some staker_index ->
      Commitment_stakers.mem ctxt rollup commitment_hash staker_index

let deallocate_commitment_contents ctxt rollup commitment_hash =
  let open Lwt_result_syntax in
  let* ctxt, _size_freed =
    Store.Commitments.remove_existing (ctxt, rollup) commitment_hash
  in
  return ctxt

let deallocate_commitment_metadata ctxt rollup commitment_hash =
  let open Lwt_result_syntax in
  let* ctxt, _size_freed =
    Store.Commitment_added.remove_existing (ctxt, rollup) commitment_hash
  in
  return ctxt

let deallocate_commitment ctxt rollup commitment_hash =
  let open Lwt_result_syntax in
  let* ctxt = deallocate_commitment_metadata ctxt rollup commitment_hash in
  deallocate_commitment_contents ctxt rollup commitment_hash

let find_commitment_to_deallocate ctxt rollup commitment_hash =
  let open Lwt_result_syntax in
  (* The recursion is safe as long as [num_commitments_to_keep] remains
     a small value. *)
  let rec aux ctxt commitment_hash n =
    if Compare.Int.(n = 0) then return (Some commitment_hash, ctxt)
    else
      let* pred_hash, ctxt =
        Commitment_storage.get_predecessor_opt_unsafe
          ctxt
          rollup
          commitment_hash
      in
      match pred_hash with
      | None -> return (None, ctxt)
      | Some pred_hash -> (aux [@ocaml.tailcall]) ctxt pred_hash (n - 1)
  in
  (* We must not remove the commitment itself as we need it to allow
     executing outbox messages for a limited period. The maximum number of
     active cemented commitments available for execution is specified in
     [ctxt.sc_rollup.max_number_of_stored_cemented_commitments].
     Instead, we remove the oldest cemented commitment that would exceed
     [max_number_of_cemented_commitments], if such exist.

     Decrease max_number_of_stored_cemented_commitments by one because
     we start counting commitments from old_lcc, rather than from new_lcc.
  *)
  let num_commitments_to_keep =
    (Raw_context.constants ctxt).sc_rollup
      .max_number_of_stored_cemented_commitments - 1
  in
  aux ctxt commitment_hash num_commitments_to_keep

(* Maximum storage size in bytes allocated during a {!refine_stake}.
   The first commitment of a inbox_level allocates the most bytes,
   subsequent commitments for the same level may cost less (e.g. same
   commitment published).

   We are looking to assert that the most possible bytes allocated in the
   storage is covered by the deposit.

   Maximum value computed and observed:
   - Commitment_first_publication_level:       4
   - Commitments:                             77
   - Commitments_added:                        4
   - Stakers:                                  4
   - Commitments_per_inbox_level:             36
   - Commitment_stakers is variable but should not exceed 10 bytes

   That is, 125 bytes are fixed.

   The variable comes from the {!Sc_rollup_staker_index.encoding}. Although,
   the index of the 10^9-th stakers is 6 bytes, 10 bytes as an over-approxiamtion
   should be fine (10 bytes also accounts for the list's overhead encoding).
*)
let max_commitment_storage_size_in_bytes = 125 + 10

(** [set_staker_commitment ctxt rollup staker_index inbox_level commitment_hash]
    updates the **latest** commitment [staker_index] stakes on.
    Adds [staker_index] to the set of stakers staking on [commitment_hash]. *)
let set_staker_commitment ctxt rollup staker_index inbox_level commitment_hash =
  let open Lwt_result_syntax in
  (* Update the latest commitment [staker_index] stakes on. *)
  let* ctxt, size_diff_stakers =
    let* ctxt, last_level = Store.Stakers.get (ctxt, rollup) staker_index in
    if Raw_level_repr.(last_level < inbox_level) then
      Store.Stakers.update (ctxt, rollup) staker_index inbox_level
    else return (ctxt, 0)
  in
  (* Adds [staker_index] to the set of stakers staking on [commitment_hash]. *)
  let* ctxt, size_diff_commitment_stakers, _stakers =
    Commitment_stakers.add ctxt rollup commitment_hash staker_index
  in
  let* () =
    (* Publishing the same commitment is not an issue. However, this causes
       a bad UX as operators can publish twice by mistake and pay twice
       the fees. *)
    fail_when
      Compare.Int.(size_diff_commitment_stakers = 0)
      (Sc_rollup_double_publish commitment_hash)
  in
  return (ctxt, size_diff_stakers + size_diff_commitment_stakers)

(** [assert_staker_dont_double_stake ctxt rollup staker_index commitments]
    asserts that [staker_index] do not stake on multiple commitments in
    [commitments]. *)
let assert_staker_dont_double_stake ctxt rollup staker_index commitments =
  let open Lwt_result_syntax in
  (* Compute the list of commitments [staker_index] stakes on. *)
  let* ctxt, staked_on_commitments =
    List.fold_left_es
      (fun (ctxt, staked_on_commitments) commitment ->
        let* ctxt, is_staked_on =
          Commitment_stakers.mem ctxt rollup commitment staker_index
        in
        if is_staked_on then return (ctxt, commitment :: staked_on_commitments)
        else return (ctxt, staked_on_commitments))
      (ctxt, [])
      commitments
  in
  let* () =
    fail_when
      Compare.List_length_with.(staked_on_commitments > 1)
      Sc_rollup_errors.Sc_rollup_staker_double_stake
  in
  return ctxt

(* TODO: https://gitlab.com/tezos/tezos/-/issues/2559
   Add a test checking that L2 nodes can catch up after going offline. *)
let refine_stake ctxt rollup commitment ~staker_index ~lcc ~lcc_inbox_level =
  let open Lwt_result_syntax in
  let publication_level = (Raw_context.current_level ctxt).level in
  (* Checks the commitment validity, see {!assert_refine_conditions_met}. *)
  let* ctxt, refine_conditions_size_diff =
    assert_refine_conditions_met
      ctxt
      rollup
      lcc
      commitment
      ~current_level:publication_level
      ~lcc_inbox_level
  in
  let*? ctxt, commitment_hash =
    Sc_rollup_commitment_storage.hash ctxt commitment
  in
  (* Adds the commitment to the storage. *)
  let* ctxt, commitment_size_diff, _commit_existed =
    Store.Commitments.add (ctxt, rollup) commitment_hash commitment
  in
  (* Initializes or fetches the level at which the commitment was first
     published. *)
  let* commitment_added_size_diff, commitment_added_level, ctxt =
    Commitment_storage.set_commitment_added
      ctxt
      rollup
      commitment_hash
      publication_level
  in
  (* Updates the [staker_index]'s metadata. *)
  let* ctxt, set_staker_commitment_size_diff =
    set_staker_commitment
      ctxt
      rollup
      staker_index
      commitment.inbox_level
      commitment_hash
  in
  (* Adds the [commitment] to the set of commitments for this inbox level. *)
  let* ctxt, commitments_per_inbox_level_size_diff, commitments =
    Commitments_per_inbox_level.add
      ctxt
      rollup
      commitment.inbox_level
      commitment_hash
  in
  (* Checks that the staker is not double staking, done at the end to avoid
     the double get to the list of commitments. *)
  let* ctxt =
    assert_staker_dont_double_stake ctxt rollup staker_index commitments
  in
  let total_size_diff =
    refine_conditions_size_diff + commitment_size_diff
    + commitment_added_size_diff + set_staker_commitment_size_diff
    + commitments_per_inbox_level_size_diff
  in
  return (commitment_hash, commitment_added_level, ctxt, total_size_diff)

let publish_commitment ctxt rollup staker commitment =
  let open Lwt_result_syntax in
  let* ctxt =
    if Constants_storage.sc_rollup_private_enable ctxt then
      Sc_rollup_whitelist_storage.check_access_to_private_rollup
        ctxt
        rollup
        staker
    else return ctxt
  in
  let* lcc, lcc_inbox_level, ctxt =
    Commitment_storage.last_cemented_commitment_hash_with_level ctxt rollup
  in
  let* () =
    fail_when
      Sc_rollup_repr.Number_of_ticks.(
        commitment.Commitment.number_of_ticks = zero)
      Sc_rollup_zero_tick_commitment
  in
  let* ctxt, staker_index_opt =
    Sc_rollup_staker_index_storage.find_staker_index_unsafe ctxt rollup staker
  in
  (* If [staker] is an active staker, it has an index. *)
  let* ctxt, balances_updates, staker_index =
    match staker_index_opt with
    | None -> deposit_stake ctxt rollup staker
    | Some staker_index -> return (ctxt, [], staker_index)
  in
  let* commitment_hash, publication_level, ctxt, _size_diff =
    refine_stake ctxt rollup ~staker_index commitment ~lcc ~lcc_inbox_level
  in
  return (commitment_hash, publication_level, ctxt, balances_updates)

(** [active_stakers_index ctxt rollup stakers] filters [stakers] to return
    only the active ones. *)
let active_stakers_index ctxt rollup stakers =
  let open Lwt_result_syntax in
  List.fold_left_es
    (fun (ctxt, active_stakers_index) staker ->
      let* ctxt, is_staker_active =
        Sc_rollup_staker_index_storage.is_active ctxt rollup staker
      in
      if is_staker_active then return (ctxt, staker :: active_stakers_index)
      else return (ctxt, active_stakers_index))
    (ctxt, [])
    stakers

let is_cementable_candidate_commitment ctxt rollup lcc commitment_hash =
  let open Lwt_result_syntax in
  let* commitment, ctxt =
    Commitment_storage.get_commitment_unsafe ctxt rollup commitment_hash
  in
  if Commitment_hash.equal commitment.predecessor lcc then
    let* ctxt, stakers_on_commitment =
      Commitment_stakers.get ctxt rollup commitment_hash
    in
    let* ctxt, active_stakers_index =
      active_stakers_index ctxt rollup stakers_on_commitment
    in
    (* The commitment is active if its predecessor is the LCC and
       at least one active steaker has staked on it. *)
    let commitment =
      if Compare.List_length_with.(active_stakers_index > 0) then
        Some commitment
      else None
    in
    return (ctxt, commitment)
  else (* Dangling commitment. *)
    return (ctxt, None)

let cementable_candidate_commitment_of_inbox_level ctxt rollup ~old_lcc
    inbox_level =
  let open Lwt_result_syntax in
  let* ctxt, commitments =
    Commitments_per_inbox_level.get ctxt rollup inbox_level
  in
  let rec collect_commitments ctxt candidate_commitment_res dangling_commitments
      = function
    | [] -> return (ctxt, candidate_commitment_res, dangling_commitments)
    | candidate_commitment_hash :: rst -> (
        let* ctxt, candidate_commitment =
          is_cementable_candidate_commitment
            ctxt
            rollup
            old_lcc
            candidate_commitment_hash
        in
        match (candidate_commitment, candidate_commitment_res) with
        | Some _, Some _ ->
            (* Second candidate commitment to cement, the inbox level is disputed. *)
            tzfail Sc_rollup_disputed
        | Some candidate_commitment, None ->
            (* First candidate commitment to cement, it becomes the result. *)
            collect_commitments
              ctxt
              (Some (candidate_commitment, candidate_commitment_hash))
              dangling_commitments
              rst
        | None, _ ->
            collect_commitments
              ctxt
              candidate_commitment_res
              (candidate_commitment_hash :: dangling_commitments)
              rst)
  in
  collect_commitments ctxt None [] commitments

(** [find_commitment_to_cement ctxt rollup ~old_lcc new_lcc_level] tries to find
    the commitment to cement at inbox level [new_lcc_level].

    A commitment can be cemented if:
    {ol
      {li The commitment's predecessor is the LCC.}
      {li The challenge window period is over.}
      {li The commitment is the only active commitment.}
    }
*)
let find_commitment_to_cement ctxt rollup ~old_lcc new_lcc_level =
  let open Lwt_result_syntax in
  (* Checks that the commitment is the only active commitment. *)
  let* ctxt, candidate_commitment, dangling_commitments =
    cementable_candidate_commitment_of_inbox_level
      ctxt
      rollup
      ~old_lcc
      new_lcc_level
  in
  match candidate_commitment with
  (* A commitment can be cemented if there is only one valid
     commitment. *)
  | Some (candidate_commitment, candidate_commitment_hash) ->
      let* ctxt, candidate_commitment_added =
        Store.Commitment_added.get (ctxt, rollup) candidate_commitment_hash
      in
      (* Checks that the commitment is past the challenge window. *)
      let* () =
        let challenge_windows_in_blocks =
          Constants_storage.sc_rollup_challenge_window_in_blocks ctxt
        in
        let current_level = (Raw_context.current_level ctxt).level in
        let min_level =
          Raw_level_repr.add
            candidate_commitment_added
            challenge_windows_in_blocks
        in
        fail_when
          Raw_level_repr.(current_level < min_level)
          (Sc_rollup_commitment_too_recent {current_level; min_level})
      in
      return
        ( ctxt,
          (candidate_commitment, candidate_commitment_hash),
          dangling_commitments )
  | None -> tzfail Sc_rollup_no_valid_commitment_to_cement

let deallocate_inbox_level ctxt rollup inbox_level new_lcc_hash
    dangling_commitments =
  let open Lwt_result_syntax in
  let* ctxt, _size_diff =
    Commitments_per_inbox_level.remove ctxt rollup inbox_level
  in
  let* ctxt =
    List.fold_left_es
      (fun ctxt commitment -> deallocate_commitment ctxt rollup commitment)
      ctxt
      dangling_commitments
  in
  let* ctxt =
    List.fold_left_es
      (fun ctxt commitment ->
        let* ctxt, _freed_size =
          Commitment_stakers.remove ctxt rollup commitment
        in
        return ctxt)
      ctxt
      (new_lcc_hash :: dangling_commitments)
  in
  let* ctxt = deallocate_commitment_metadata ctxt rollup new_lcc_hash in
  let* ctxt, _size_freed =
    Store.Commitment_first_publication_level.remove_existing
      (ctxt, rollup)
      inbox_level
  in
  return ctxt

let update_saved_cemented_commitments ctxt rollup old_lcc =
  let open Lwt_result_syntax in
  let* too_old_cemented_commitment_hash_opt, ctxt =
    find_commitment_to_deallocate ctxt rollup old_lcc
  in
  match too_old_cemented_commitment_hash_opt with
  | None -> return ctxt
  | Some too_old_cemented_commitment_hash ->
      if Commitment_hash.(equal too_old_cemented_commitment_hash zero) then
        return ctxt
      else
        deallocate_commitment_contents
          ctxt
          rollup
          too_old_cemented_commitment_hash

let cement_commitment ctxt rollup =
  let open Lwt_result_syntax in
  let* old_lcc, old_lcc_level, ctxt =
    Commitment_storage.last_cemented_commitment_hash_with_level ctxt rollup
  in
  let sc_rollup_commitment_period =
    Constants_storage.sc_rollup_commitment_period_in_blocks ctxt
  in
  let new_lcc_level =
    Raw_level_repr.add old_lcc_level sc_rollup_commitment_period
  in
  (* Assert conditions to cement are met. *)
  let* ctxt, (new_lcc_commitment, new_lcc_commitment_hash), dangling_commitments
      =
    find_commitment_to_cement ctxt rollup ~old_lcc new_lcc_level
  in
  (* Update the LCC. *)
  let* ctxt, _size_diff =
    Store.Last_cemented_commitment.update ctxt rollup new_lcc_commitment_hash
  in
  (* Clean the storage. *)
  let* ctxt =
    deallocate_inbox_level
      ctxt
      rollup
      new_lcc_commitment.inbox_level
      new_lcc_commitment_hash
      dangling_commitments
  in
  (* Update the saved cemented commitments. *)
  let* ctxt = update_saved_cemented_commitments ctxt rollup old_lcc in
  return (ctxt, new_lcc_commitment, new_lcc_commitment_hash)

let remove_staker ctxt rollup staker =
  let open Lwt_result_syntax in
  let staker_contract, stake = get_contract_and_stake ctxt staker in
  let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in
  let* ctxt, balance_updates =
    Token.transfer
      ctxt
      (`Frozen_bonds (staker_contract, bond_id))
      `Sc_rollup_refutation_punishments
      stake
  in
  let* ctxt = Sc_rollup_staker_index_storage.remove_staker ctxt rollup staker in
  return (ctxt, balance_updates)

let commitments_of_inbox_level = Commitments_per_inbox_level.get

let stakers_of_commitment = Commitment_stakers.get

module Internal_for_tests = struct
  let deposit_stake = deposit_stake

  let refine_stake ctxt rollup staker commitment =
    let open Lwt_result_syntax in
    let* lcc, lcc_inbox_level, _ctxt =
      Commitment_storage.last_cemented_commitment_hash_with_level ctxt rollup
    in
    let* _ctxt, staker_index =
      Sc_rollup_staker_index_storage.get_staker_index_unsafe ctxt rollup staker
    in
    let* commitment_hash, publication_level, ctxt, size_diff =
      refine_stake ctxt rollup commitment ~staker_index ~lcc ~lcc_inbox_level
    in
    assert (Compare.Int.(size_diff < max_commitment_storage_size_in_bytes)) ;
    return (commitment_hash, publication_level, ctxt)

  let max_commitment_storage_size_in_bytes =
    max_commitment_storage_size_in_bytes
end
package tezos-protocol-alpha

Source file sc_rollup_stake_storage.ml

Source file `sc_rollup_stake_storage.ml`
